From 1f3d7b45349d43e5cc02594083e0cd44ef730992 Mon Sep 17 00:00:00 2001 From: Andrew Tropin Date: Fri, 18 Jun 2021 07:15:36 +0300 Subject: gexp: 'mixed-text-file' UTF-8-encodes its output. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/gexp.scm (mixed-text-file)[build]: Call 'set-port-encoding!'. Signed-off-by: Ludovic Courtès --- guix/gexp.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index afb935761e..187f5c5e85 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1921,6 +1921,7 @@ (define* (mixed-text-file name #:rest text) (define build (gexp (call-with-output-file (ungexp output "out") (lambda (port) + (set-port-encoding! port "UTF-8") (display (string-append (ungexp-splicing text)) port))))) (computed-file name build)) -- cgit v1.2.3 From 9c93573d15e90232de0effb4c28332c454dbc290 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Thu, 17 Jun 2021 14:11:19 +0200 Subject: build: Make outputs of node-build-system reproducible. package.json records two hashes of package.tgz, which change for each build, resulting in non-reproducible builds. * guix/build/node-build-system.scm (repack): Add reproducibility options to tar command. --- guix/build/node-build-system.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index a55cab237c..70a367618e 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -120,7 +120,14 @@ (define* (check #:key tests? inputs #:allow-other-keys) #t) (define* (repack #:key inputs #:allow-other-keys) - (invoke "tar" "-czf" "../package.tgz" ".") + (invoke "tar" + ;; Add options suggested by https://reproducible-builds.org/docs/archives/ + "--sort=name" + (string-append "--mtime=@" (getenv "SOURCE_DATE_EPOCH")) + "--owner=0" + "--group=0" + "--numeric-owner" + "-czf" "../package.tgz" ".") #t) (define* (install #:key outputs inputs #:allow-other-keys) -- cgit v1.2.3 From 468a5f8676c82e17de98d12077c671823177d944 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 24 Jun 2021 13:57:54 +0200 Subject: lint: 'with-networking-fail-safe' handles 'gnutls-error' exceptions. * guix/lint.scm (call-with-networking-fail-safe): Add clause for 'gnutls-error'. --- guix/lint.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index d65d5ce8f9..36a672c081 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -68,6 +68,7 @@ (define-module (guix lint) . guix:open-connection-for-uri))) #:use-module (web request) #:use-module (web response) + #:autoload (gnutls) (error->string) #:use-module (srfi srfi-1) #:use-module (srfi srfi-6) ;Unicode string ports #:use-module (srfi srfi-9) @@ -1162,6 +1163,11 @@ (define (call-with-networking-fail-safe message error-value proc) message (tls-certificate-error-string args)) error-value) + (('gnutls-error error function _ ...) + (warning (G_ "~a: TLS error in '~a': ~a~%") + message + function (error->string error)) + error-value) ((and ('system-error _ ...) args) (let ((errno (system-error-errno args))) (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED)) -- cgit v1.2.3 From 8a81ae61c183085b3a1edc4572d721ac5b2a581c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 24 Jun 2021 14:01:53 +0200 Subject: lint: 'github-url' checker gracefully handles networking errors. Fixes . Reported by Tobias Geerinckx-Rice . * guix/lint.scm (call-with-networking-fail-safe, with-networking-fail-safe): Move higher in the file. * guix/lint.scm (check-github-url): Wrap call to 'follow-redirects-to-github' in 'with-networking-fail-safe'. --- guix/lint.scm | 108 ++++++++++++++++++++++++++++++---------------------------- 1 file changed, 55 insertions(+), 53 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 36a672c081..70ed677a54 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -617,6 +617,51 @@ (define response (_ (values 'unknown-protocol #f))))) +(define (call-with-networking-fail-safe message error-value proc) + "Call PROC catching any network-related errors. Upon a networking error, +display a message including MESSAGE and return ERROR-VALUE." + (guard (c ((http-get-error? c) + (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%") + message + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + error-value)) + (catch #t + proc + (match-lambda* + (('getaddrinfo-error errcode) + (warning (G_ "~a: host lookup failure: ~a~%") + message + (gai-strerror errcode)) + error-value) + (('tls-certificate-error args ...) + (warning (G_ "~a: TLS certificate error: ~a") + message + (tls-certificate-error-string args)) + error-value) + (('gnutls-error error function _ ...) + (warning (G_ "~a: TLS error in '~a': ~a~%") + message + function (error->string error)) + error-value) + ((and ('system-error _ ...) args) + (let ((errno (system-error-errno args))) + (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED)) + (let ((details (call-with-output-string + (lambda (port) + (print-exception port #f (car args) + (cdr args)))))) + (warning (G_ "~a: ~a~%") message details) + error-value) + (apply throw args)))) + (args + (apply throw args)))))) + +(define-syntax-rule (with-networking-fail-safe message error-value exp ...) + (call-with-networking-fail-safe message error-value + (lambda () exp ...))) + (define (tls-certificate-error-string args) "Return a string explaining the 'tls-certificate-error' arguments ARGS." (call-with-output-string @@ -1035,15 +1080,17 @@ (define (follow-redirects-to-github uri) (eqv? (origin-method origin) url-fetch)) (filter-map (lambda (uri) - (and=> (follow-redirects-to-github uri) + (and=> (with-networking-fail-safe + (format #f (G_ "while accessing '~a'") uri) + #f + (follow-redirects-to-github uri)) (lambda (github-uri) - (if (string=? github-uri uri) - #f - (make-warning - package - (G_ "URL should be '~a'") - (list github-uri) - #:field 'source))))) + (and (not (string=? github-uri uri)) + (make-warning + package + (G_ "URL should be '~a'") + (list github-uri) + #:field 'source))))) (origin-uris origin)) '()))) @@ -1140,51 +1187,6 @@ (define (check-license package) (make-warning package (G_ "invalid license field") #:field 'license))))) -(define (call-with-networking-fail-safe message error-value proc) - "Call PROC catching any network-related errors. Upon a networking error, -display a message including MESSAGE and return ERROR-VALUE." - (guard (c ((http-get-error? c) - (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%") - message - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - error-value)) - (catch #t - proc - (match-lambda* - (('getaddrinfo-error errcode) - (warning (G_ "~a: host lookup failure: ~a~%") - message - (gai-strerror errcode)) - error-value) - (('tls-certificate-error args ...) - (warning (G_ "~a: TLS certificate error: ~a") - message - (tls-certificate-error-string args)) - error-value) - (('gnutls-error error function _ ...) - (warning (G_ "~a: TLS error in '~a': ~a~%") - message - function (error->string error)) - error-value) - ((and ('system-error _ ...) args) - (let ((errno (system-error-errno args))) - (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED)) - (let ((details (call-with-output-string - (lambda (port) - (print-exception port #f (car args) - (cdr args)))))) - (warning (G_ "~a: ~a~%") message details) - error-value) - (apply throw args)))) - (args - (apply throw args)))))) - -(define-syntax-rule (with-networking-fail-safe message error-value exp ...) - (call-with-networking-fail-safe message error-value - (lambda () exp ...))) - (define (current-vulnerabilities*) "Like 'current-vulnerabilities', but return the empty list upon networking or HTTP errors. This allows network-less operation and makes problems with -- cgit v1.2.3 From d3e8890613f62a6fc2620e544e34fc64ceb832e7 Mon Sep 17 00:00:00 2001 From: Sergey Trofimov Date: Tue, 15 Jun 2021 17:37:21 +0200 Subject: gnu: Add ausweisapp2. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/packages/security-token.scm (ausweisapp2): New variable. * guix/licenses.scm (eupl1.2): New variable. Co-authored-by: Ludovic Courtès --- gnu/packages/security-token.scm | 49 +++++++++++++++++++++++++++++++++++++++++ guix/licenses.scm | 6 +++++ 2 files changed, 55 insertions(+) (limited to 'guix') diff --git a/gnu/packages/security-token.scm b/gnu/packages/security-token.scm index 89783de965..49ca1dc01e 100644 --- a/gnu/packages/security-token.scm +++ b/gnu/packages/security-token.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2018 Arun Isaac ;;; Copyright © 2020 Raphaël Mélotte ;;; Copyright © 2021 Antero Mejr +;;; Copyright © 2021 Sergey Trofimov ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,6 +35,7 @@ (define-module (gnu packages security-token) #:use-module (guix gexp) #:use-module (guix git-download) #:use-module (guix build-system cargo) + #:use-module (guix build-system cmake) #:use-module (guix build-system gnu) #:use-module (guix build-system glib-or-gtk) #:use-module (guix build-system python) @@ -56,6 +58,7 @@ (define-module (gnu packages security-token) #:use-module (gnu packages cyrus-sasl) #:use-module (gnu packages popt) #:use-module (gnu packages readline) + #:use-module (gnu packages qt) #:use-module (gnu packages tls) #:use-module (gnu packages tex) #:use-module (gnu packages perl) @@ -720,3 +723,49 @@ (define-public nitrocli for interaction with Nitrokey Pro, Nitrokey Storage, and Librem Key devices.") (license license:gpl3+))) + +(define-public ausweisapp2 + (package + (name "ausweisapp2") + (version "1.22.2") + (source (origin + (method url-fetch) + (uri (string-append "https://github.com/Governikus/AusweisApp2/releases" + "/download/" version "/AusweisApp2-" version ".tar.gz")) + (sha256 + (base32 + "1qh1m057va7njs3yk0s31kwsvv44fjlsdac6lhiw5npcwssgjn8l")))) + + (build-system cmake-build-system) + (native-inputs + `(("pkg-config" ,pkg-config) + ("qttools" ,qttools))) + (inputs + `(("qtbase" ,qtbase-5) + ("qtsvg" ,qtsvg) + ("qtdeclarative" ,qtdeclarative) + ("qtwebsockets" ,qtwebsockets) + ("qtgraphicaleffects" ,qtgraphicaleffects) + ("qtquickcontrols2" ,qtquickcontrols2) + ("pcsc-lite" ,pcsc-lite) + ("openssl" ,openssl))) + (arguments + `(#:modules ((guix build cmake-build-system) + (guix build qt-utils) + (guix build utils)) + #:imported-modules (,@%cmake-build-system-modules + (guix build qt-utils)) + #:phases + (modify-phases %standard-phases + (add-after 'install 'wrap-qt + (lambda* (#:key outputs #:allow-other-keys) + (wrap-qt-program (assoc-ref outputs "out") "AusweisApp2")))))) + (home-page "https://github.com/Governikus/AusweisApp2") + (synopsis + "Authentication program for German ID cards and residence permits") + (description + "This application is developed and issued by the German government to be +used for online authentication with electronic German ID cards and residence +titles. To use this app, a supported RFID card reader or NFC-enabled smart +phone is required.") + (license license:eupl1.2))) diff --git a/guix/licenses.scm b/guix/licenses.scm index e7457799ce..3affe1e920 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -56,6 +56,7 @@ (define-module (guix licenses) edl1.0 epl1.0 epl2.0 + eupl1.2 expat freetype freebsd-doc @@ -307,6 +308,11 @@ (define epl2.0 "https://www.eclipse.org/legal/epl-2.0/" "https://www.gnu.org/licenses/license-list#EPL2")) +(define eupl1.2 + (license "EUPL 1.2" + "https://directory.fsf.org/wiki/License:EUPL-1.2" + "https://www.gnu.org/licenses/license-list#EUPL-1.2")) + (define expat (license "Expat" "http://directory.fsf.org/wiki/License:Expat" -- cgit v1.2.3 From 1b4931555b3e876a313ce31273984f3a59b2ec78 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jun 2021 11:26:22 +0200 Subject: deploy: Leave on hard error. Previously, the error message would be displayed, followed by a backtrace ending in &non-continuable. * guix/scripts/deploy.scm (deploy-machine*): Call 'leave' rather than 'report-error' when C is a &message. --- guix/scripts/deploy.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 7c62b05d12..8bb8a7932e 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -129,9 +129,9 @@ (define (deploy-machine* store machine) (raise c)) ((message-condition? c) - (report-error (G_ "failed to deploy ~a: ~a~%") - (machine-display-name machine) - (condition-message c))) + (leave (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (condition-message c))) ((deploy-error? c) (when (deploy-error-should-roll-back c) (info (G_ "rolling back ~a...~%") -- cgit v1.2.3 From 7916201c4da9a29abc0ac1ef3ee80c8e3efdcf72 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jun 2021 11:33:27 +0200 Subject: reconfigure: Use 'formatted-message'. * guix/scripts/system/reconfigure.scm (ensure-forward-reconfigure): Use 'formatted-message'. * guix/scripts/deploy.scm (deploy-machine*): Handle it. --- guix/scripts/deploy.scm | 9 +++++++++ guix/scripts/system/reconfigure.scm | 9 ++++----- 2 files changed, 13 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 8bb8a7932e..1707622c4f 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -28,6 +28,8 @@ (define-module (guix scripts deploy) #:use-module (guix utils) #:use-module (guix grafts) #:use-module (guix status) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -132,6 +134,13 @@ (define (deploy-machine* store machine) (leave (G_ "failed to deploy ~a: ~a~%") (machine-display-name machine) (condition-message c))) + ((formatted-message? c) + (leave (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (apply format #f + (gettext (formatted-message-string c) + %gettext-domain) + (formatted-message-arguments c)))) ((deploy-error? c) (when (deploy-error-should-roll-back c) (info (G_ "rolling back ~a...~%") diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 39a818dd0b..49da6ecb16 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -308,12 +308,11 @@ (define (ensure-forward-reconfigure channel start commit relation) ('self #t) (_ (raise (make-compound-condition - (condition - (&message (message - (format #f (G_ "\ + (formatted-message (G_ "\ aborting reconfiguration because commit ~a of channel '~a' is not a descendant of ~a") - commit (channel-name channel) - start))) + commit (channel-name channel) + start) + (condition (&fix-hint (hint (G_ "Use @option{--allow-downgrades} to force this downgrade."))))))))) -- cgit v1.2.3 From dfac3e643a924ccefc997b4433a0b5c35928d657 Mon Sep 17 00:00:00 2001 From: Philip Munksgaard Date: Fri, 18 Jun 2021 14:48:13 +0200 Subject: import: hackage: Support "common" field and imports MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * guix/import/cabal.scm (make-cabal-parser): Modify. (is-common): New variable. (lex-common): New procedure. (is-id): Modify. (eval-cabal): Modify. * tests/hackage.scm ("hackage->guix-package test cabal import") New test. Signed-off-by: Ludovic Courtès --- guix/import/cabal.scm | 27 +++++++++++++++++++++++++-- tests/hackage.scm | 42 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index da00019297..e9a0179b3d 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -145,7 +145,7 @@ (define (make-cabal-parser) (lalr-parser ;; --- token definitions (CCURLY VCCURLY OPAREN CPAREN TEST ID VERSION RELATION TRUE FALSE -ANY -NONE - (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB OCURLY) + (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB COMMON OCURLY) (left: OR) (left: PROPERTY AND) (right: ELSE NOT)) @@ -155,6 +155,7 @@ (define (make-cabal-parser) (sections source-repo) : (append $1 (list $2)) (sections executables) : (append $1 $2) (sections test-suites) : (append $1 $2) + (sections common) : (append $1 $2) (sections custom-setup) : (append $1 $2) (sections benchmarks) : (append $1 $2) (sections lib-sec) : (append $1 (list $2)) @@ -178,6 +179,10 @@ (define (make-cabal-parser) (ts-sec) : (list $1)) (ts-sec (TEST-SUITE OCURLY exprs CCURLY) : `(section test-suite ,$1 ,$3) (TEST-SUITE open exprs close) : `(section test-suite ,$1 ,$3)) + (common (common common-sec) : (append $1 (list $2)) + (common-sec) : (list $1)) + (common-sec (COMMON OCURLY exprs CCURLY) : `(section common ,$1 ,$3) + (COMMON open exprs close) : `(section common ,$1 ,$3)) (custom-setup (CUSTOM-SETUP exprs) : (list `(section custom-setup ,$1 ,$2))) (benchmarks (benchmarks bm-sec) : (append $1 (list $2)) (bm-sec) : (list $1)) @@ -367,6 +372,9 @@ (define is-exec (make-rx-matcher "^executable +([a-z0-9_-]+)" (define is-test-suite (make-rx-matcher "^test-suite +([a-z0-9_-]+)" regexp/icase)) +(define is-common (make-rx-matcher "^common +([a-z0-9_-]+)" + regexp/icase)) + (define is-custom-setup (make-rx-matcher "^(custom-setup)" regexp/icase)) @@ -394,7 +402,7 @@ (define (is-or s) (string=? s "||")) (define (is-id s port) (let ((cabal-reserved-words '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup" - "source-repository" "benchmark")) + "source-repository" "benchmark" "common")) (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) (c (peek-char port))) (unread-string spaces port) @@ -469,6 +477,8 @@ (define (lex-exec exec-rx-res loc) (lex-rx-res exec-rx-res 'EXEC loc)) (define (lex-test-suite ts-rx-res loc) (lex-rx-res ts-rx-res 'TEST-SUITE loc)) +(define (lex-common common-rx-res loc) (lex-rx-res common-rx-res 'COMMON loc)) + (define (lex-custom-setup ts-rx-res loc) (lex-rx-res ts-rx-res 'CUSTOM-SETUP loc)) (define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc)) @@ -570,6 +580,7 @@ (define (lex-line port loc) ((is-src-repo s) => (cut lex-src-repo <> loc)) ((is-exec s) => (cut lex-exec <> loc)) ((is-test-suite s) => (cut lex-test-suite <> loc)) + ((is-common s) => (cut lex-common <> loc)) ((is-custom-setup s) => (cut lex-custom-setup <> loc)) ((is-benchmark s) => (cut lex-benchmark <> loc)) ((is-lib s) (lex-lib loc)) @@ -796,7 +807,16 @@ (define (flag name) (let ((value (or (assoc-ref env name) (assoc-ref (cabal-flags->alist (cabal-flags)) name)))) (if (eq? value 'false) #f #t))) + + (define common-stanzas + (filter-map (match-lambda + (('section 'common common-name common) + (cons common-name common)) + (_ #f)) + cabal-sexp)) + (define (eval sexp) + "Given an SEXP and an ENV, return the evaluated (SEXP . ENV)." (match sexp (() '()) ;; nested 'if' @@ -831,6 +851,9 @@ (define (eval sexp) (list 'section type name (eval parameters))) (((? string? name) values) (list name values)) + ((("import" imports) rest ...) + (eval (append (append-map (cut assoc-ref common-stanzas <>) imports) + rest))) ((element rest ...) (cons (eval element) (eval rest))) (_ (raise (condition diff --git a/tests/hackage.scm b/tests/hackage.scm index 66a13d9881..53972fc643 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -388,4 +388,46 @@ (define-package-matcher match-ghc-foo-revision #t) (x (pk 'fail x #f)))) +(define test-cabal-import + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: description +license: BSD3 +common commons + build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 + +executable cabal + import: commons +") + +(define-package-matcher match-ghc-foo-import + ('package + ('name "ghc-foo") + ('version "1.0.0") + ('source + ('origin + ('method 'url-fetch) + ('uri ('string-append + "https://hackage.haskell.org/package/foo/foo-" + 'version + ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'haskell-build-system) + ('inputs + ('quasiquote + (("ghc-http" ('unquote 'ghc-http))))) + ('home-page "http://test.org") + ('synopsis (? string?)) + ('description (? string?)) + ('license 'license:bsd-3))) + +(test-assert "hackage->guix-package test cabal import" + (eval-test-with-cabal test-cabal-import match-ghc-foo-import)) + (test-end "hackage") -- cgit v1.2.3 From 7fe195f3b79a9a1369fa9f14539f82a5b5c880de Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jun 2021 16:11:02 +0200 Subject: guix substitute: Adjust comment about GnuTLS bug. * guix/scripts/substitute.scm (call-with-cached-connection): Adjust comment. --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 3ea1c73e10..03115ffe44 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -423,7 +423,7 @@ (define (call-with-cached-connection uri proc) (list error/invalid-session ;; XXX: These two are not properly handled in - ;; GnuTLS < 3.7.2, in + ;; GnuTLS < 3.7.3, in ;; 'write_to_session_record_port'; see ;; . error/again error/interrupted))) -- cgit v1.2.3 From b36267b1d96ac344d2b42c9822ce04b4c3117f85 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jun 2021 16:11:55 +0200 Subject: download: 'tls-wrap' retries handshake upon non-fatal errors. Fixes . Reported by Domagoj Stolfa . * guix/build/download.scm (tls-wrap): Retry up to 5 times when 'handshake' throws a non-fatal error. --- guix/build/download.scm | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index b14db42352..54627eefa2 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -281,21 +281,27 @@ (define (log level str) ;;(set-log-level! 10) ;;(set-log-procedure! log) - (catch 'gnutls-error - (lambda () - (handshake session)) - (lambda (key err proc . rest) - (cond ((eq? err error/warning-alert-received) - ;; Like Wget, do no stop upon non-fatal alerts such as - ;; 'alert-description/unrecognized-name'. - (format (current-error-port) - "warning: TLS warning alert received: ~a~%" - (alert-description->string (alert-get session))) - (handshake session)) - (else - ;; XXX: We'd use 'gnutls_error_is_fatal' but (gnutls) doesn't - ;; provide a binding for this. - (apply throw key err proc rest))))) + (let loop ((retries 5)) + (catch 'gnutls-error + (lambda () + (handshake session)) + (lambda (key err proc . rest) + (cond ((eq? err error/warning-alert-received) + ;; Like Wget, do no stop upon non-fatal alerts such as + ;; 'alert-description/unrecognized-name'. + (format (current-error-port) + "warning: TLS warning alert received: ~a~%" + (alert-description->string (alert-get session))) + (handshake session)) + (else + (if (or (fatal-error? err) (zero? retries)) + (apply throw key err proc rest) + (begin + ;; We got 'error/again' or similar; try again. + (format (current-error-port) + "warning: TLS non-fatal error: ~a~%" + (error->string err)) + (loop (- retries 1))))))))) ;; Verify the server's certificate if needed. (when verify-certificate? -- cgit v1.2.3 From 9d9152425e96c408357d0f4961767a5c08076c13 Mon Sep 17 00:00:00 2001 From: Sarah Morgensen via Guix-patches via Date: Wed, 23 Jun 2021 15:46:46 -0700 Subject: import: go: Fix match-error in 'go-package-description' MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/go.scm (go-package-description): Make sure description* is always a list, so the result is properly matched. Signed-off-by: Björn Höfling --- guix/import/go.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/go.scm b/guix/import/go.scm index d110954664..5e23d6a2b3 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Ludovic Courtès ;;; Copyright © 2021 Xinglu Chen +;; Copyright © 2021 Sarah Morgensen ;;; ;;; This file is part of GNU Guix. ;;; @@ -186,8 +187,9 @@ (define (go-package-description name) (description (if (not (null? overview)) overview (select-content sxml))) - (description* (and (not (null? description)) - (first description)))) + (description* (if (not (null? description)) + (first description) + description))) (match description* (() #f) ;nothing selected ((p elements ...) -- cgit v1.2.3 From 0f2a17de06a52ca56c90368e29644036c14abad2 Mon Sep 17 00:00:00 2001 From: Leo Prikler Date: Mon, 28 Jun 2021 21:54:02 +0200 Subject: guix: Delete duplicates from emacs-load-path. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It has been reported in IRC, that directories may show up multiple times in subdirs.el, probably a result of propagation. This can for instance be seen by ‘guix environment --ad-hoc emacs emacs-guix’, which will generate multiple references to dash. With this patch only one reference per package is generated. * guix/profiles.scm (emacs-subdirs): wrap subdirs added to ‘normal-top-level-add-to-load-path’ in ‘delete-duplictes’. --- guix/profiles.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 8c02149c6f..2486f91d09 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1150,7 +1150,7 @@ (define build (lambda (port) (write `(normal-top-level-add-to-load-path - (list ,@subdirs)) + (list ,@(delete-duplicates subdirs))) port) (newline port) #t))))))) -- cgit v1.2.3 From ab37731a8d51d968508dda85f1f434f0d3369055 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jun 2021 22:52:16 +0200 Subject: ui: Have 'guix help' stat less. This reduces the number of syscalls for: env -i $(type -P strace) -c $(type -P guix) help from 4.3K to 2.2K, thereby reducing startup time. Reported by Julien Lepiller. * guix/ui.scm (run-guix-command): Move %FILE-PORT-NAME-CANONICALIZATION to... (run-guix): ... here. --- guix/ui.scm | 64 ++++++++++++++++++++++++++++++------------------------------- 1 file changed, 32 insertions(+), 32 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index d3e01f846d..26a437e904 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -2139,16 +2139,14 @@ (define module (let ((command-main (module-ref module (symbol-append 'guix- command)))) (parameterize ((program-name command)) - ;; Disable canonicalization so we don't don't stat unreasonably. - (with-fluids ((%file-port-name-canonicalization #f)) - (dynamic-wind - (const #f) - (lambda () - (apply command-main args)) - (lambda () - ;; Abuse 'exit-hook' (which is normally meant to be used by the - ;; REPL) to run things like profiling hooks upon completion. - (run-hook exit-hook))))))) + (dynamic-wind + (const #f) + (lambda () + (apply command-main args)) + (lambda () + ;; Abuse 'exit-hook' (which is normally meant to be used by the + ;; REPL) to run things like profiling hooks upon completion. + (run-hook exit-hook)))))) (define (run-guix . args) "Run the 'guix' command defined by command line ARGS. @@ -2160,28 +2158,30 @@ (define option? (cut string-prefix? "-" <>)) ;; number of 'stat' calls per entry in %LOAD-PATH. Shamelessly remove it. (set! %load-extensions '(".scm")) - (match args - (() - (format (current-error-port) - (G_ "guix: missing command name~%")) - (show-guix-usage)) - ((or ("-h") ("--help")) - (leave-on-EPIPE (show-guix-help))) - ((or ("-V") ("--version")) - (show-version-and-exit "guix")) - (((? option? o) args ...) - (format (current-error-port) - (G_ "guix: unrecognized option '~a'~%") o) - (show-guix-usage)) - (("help" command) - (apply run-guix-command (string->symbol command) - '("--help"))) - (("help" args ...) - (leave-on-EPIPE (show-guix-help))) - ((command args ...) - (apply run-guix-command - (string->symbol command) - args)))) + ;; Disable canonicalization so we don't don't stat unreasonably. + (with-fluids ((%file-port-name-canonicalization #f)) + (match args + (() + (format (current-error-port) + (G_ "guix: missing command name~%")) + (show-guix-usage)) + ((or ("-h") ("--help")) + (leave-on-EPIPE (show-guix-help))) + ((or ("-V") ("--version")) + (show-version-and-exit "guix")) + (((? option? o) args ...) + (format (current-error-port) + (G_ "guix: unrecognized option '~a'~%") o) + (show-guix-usage)) + (("help" command) + (apply run-guix-command (string->symbol command) + '("--help"))) + (("help" args ...) + (leave-on-EPIPE (show-guix-help))) + ((command args ...) + (apply run-guix-command + (string->symbol command) + args))))) (define (guix-main arg0 . args) (initialize-guix) -- cgit v1.2.3 From 0ba4f0caa4148c0e1080218ffcbd32127f41887f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jun 2021 23:34:36 +0200 Subject: pull: Autoload (gnu ...) modules. This reduces startup time for 'guix pull --help' and similar. * guix/scripts/pull.scm: Autoload (gnu ...) modules. --- guix/scripts/pull.scm | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 07613240a8..c880a5b1c8 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2017 Marius Bakke ;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice ;;; @@ -44,14 +44,12 @@ (define-module (guix scripts pull) #:select (with-file-lock/no-wait)) #:use-module (guix git) #:use-module (git) - #:use-module (gnu packages) - #:use-module ((guix scripts package) #:select (build-and-use-profile - delete-matching-generations)) - #:use-module ((gnu packages base) #:select (canonical-package)) - #:use-module (gnu packages guile) - #:use-module ((gnu packages bootstrap) - #:select (%bootstrap-guile)) - #:use-module ((gnu packages certs) #:select (le-certs)) + #:autoload (gnu packages) (fold-available-packages) + #:autoload (guix scripts package) (build-and-use-profile + delete-matching-generations) + #:autoload (gnu packages base) (canonical-package) + #:autoload (gnu packages bootstrap) (%bootstrap-guile) + #:autoload (gnu packages certs) (le-certs) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) -- cgit v1.2.3 From f386a993ef9b75e37d708aee5f78312f7bcc9425 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jun 2021 23:36:50 +0200 Subject: pull: Use SRFI-71 instead of SRFI-11. * guix/scripts/pull.scm (display-new/upgraded-packages): Use SRFI-71 'let'. --- guix/scripts/pull.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index c880a5b1c8..fb8ce50fa7 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -51,11 +51,11 @@ (define-module (guix scripts pull) #:autoload (gnu packages bootstrap) (%bootstrap-guile) #:autoload (gnu packages certs) (le-certs) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 format) @@ -601,7 +601,7 @@ (define list->enumeration (string-join lst ", "))) (cut string-join <> ", "))) - (let-values (((new upgraded) (new/upgraded-packages alist1 alist2))) + (let ((new upgraded (new/upgraded-packages alist1 alist2))) (define new-count (length new)) (define upgraded-count (length upgraded)) -- cgit v1.2.3 From fd62b4cf88578ebd8f42ccda94831a254425a329 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jun 2021 23:52:30 +0200 Subject: guix build: Autoload (gnu packages). * guix/scripts/build.scm: Autoload (gnu packages). --- guix/scripts/build.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 97e2f5a167..187ba45e79 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -46,7 +46,9 @@ (define-module (guix scripts build) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:use-module (gnu packages) + #:autoload (gnu packages) (%package-module-path + %patch-path + specification->package) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) -- cgit v1.2.3 From 05528dcd4827ef449e2014794ab74085e57651b9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Jun 2021 00:10:54 +0200 Subject: Revert "guix build: Autoload (gnu packages)." This reverts commit fd62b4cf88578ebd8f42ccda94831a254425a329, which would lead 'GUIX_PACKAGE_PATH' to be ignored for instance when using 'guix build -f file.scm', as shown by 'tests/guix-build.sh'. --- guix/scripts/build.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 187ba45e79..97e2f5a167 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -46,9 +46,7 @@ (define-module (guix scripts build) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:autoload (gnu packages) (%package-module-path - %patch-path - specification->package) + #:use-module (gnu packages) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) -- cgit v1.2.3 From 5ef96ecaaeeabd5500e406f0103ca52ec079fdb9 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Tue, 29 Jun 2021 00:06:34 +0200 Subject: weather: Handle zero requested store items gracefully. This can happen if the weather information of a package is requested for an unsupported system. For example, try "guix weather icecat --system=aarch64-linux". * guix/scripts/weather.scm (report-server-coverage): Do not divide by zero when zero store items are requested from a server. Fixes: Reported-By: Jack Hill Signed-off-by: Mathieu Othacehe --- guix/scripts/weather.scm | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 6d925d416c..06312d65a2 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2018 Kyle Meyer ;;; Copyright © 2020 Simon Tournier +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -185,9 +186,12 @@ (define* (report-server-coverage server items #:key display-missing?) "Report the subset of ITEMS available as substitutes on SERVER. When DISPLAY-MISSING? is true, display the list of missing substitutes. -Return the coverage ratio, an exact number between 0 and 1." +Return the coverage ratio, an exact number between 0 and 1. +In case ITEMS is an empty list, return 1 instead." (define MiB (* (expt 2 20) 1.)) + ;; TRANSLATORS: it is quite possible zero store items are + ;; looked for. (format #t (G_ "looking for ~h store items on ~a...~%") (length items) server) @@ -208,9 +212,10 @@ (define MiB (* (expt 2 20) 1.)) narinfos)) (time (+ (time-second time) (/ (time-nanosecond time) 1e9)))) - (format #t (G_ " ~,1f% substitutes available (~h out of ~h)~%") - (* 100. (/ obtained requested 1.)) - obtained requested) + (when (> requested 0) + (format #t (G_ " ~,1f% substitutes available (~h out of ~h)~%") + (* 100. (/ obtained requested 1.)) + obtained requested)) (let ((total (/ (reduce + 0 sizes) MiB))) (match (length sizes) ((? zero?) @@ -299,7 +304,9 @@ (define MiB (* (expt 2 20) 1.)) ;; Return the coverage ratio. (let ((total (length items))) - (/ (- total (length missing)) total))))) + (if (> total 0) + (/ (- total (length missing)) total) + 1))))) ;;; -- cgit v1.2.3 From 91e837283885ed735782709668c5ea7557e27dfe Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 15 Jun 2021 10:13:29 -0400 Subject: pack: Extract builder code from self-contained-tarball. This is made to allow reusing it for the debian-archive pack format, added in a subsequent commit. * guix/scripts/pack.scm (self-contained-tarball/builder): New procedure, containing the build code extracted from self-contained-tarball. (self-contained-tarball): Use the above procedure. --- guix/scripts/pack.scm | 270 ++++++++++++++++++++++++++------------------------ 1 file changed, 141 insertions(+), 129 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 8cb4e6d2cc..ac477850e6 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -172,22 +172,17 @@ (define db-file (computed-file "store-database" build #:options `(#:references-graphs ,(zip labels items)))) -(define* (self-contained-tarball name profile - #:key target - (profile-name "guix-profile") - deduplicate? - entry-point - (compressor (first %compressors)) - localstatedir? - (symlinks '()) - (archiver tar)) - "Return a self-contained tarball containing a store initialized with the -closure of PROFILE, a derivation. The tarball contains /gnu/store; if -LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db -with a properly initialized store database. - -SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be -added to the pack." + +;;; +;;; Tarball format. +;;; +(define* (self-contained-tarball/builder profile + #:key (profile-name "guix-profile") + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (archiver tar)) + "Return the G-Expression of the builder used for self-contained-tarball." (define database (and localstatedir? (file-append (store-database (list profile)) @@ -209,125 +204,142 @@ (define (import-module? module) (and (not-config? module) (not (equal? '(guix store deduplication) module)))) - (define build - (with-imported-modules (source-module-closure - `((guix build utils) - (guix build union) - (gnu build install)) - #:select? import-module?) - #~(begin - (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (with-imported-modules (source-module-closure + `((guix build utils) + (guix build union) + (gnu build install)) + #:select? import-module?) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define %root "root") + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. For testing, we use the bootstrap tar, which is + ;; older and doesn't support it. + (define tar-supports-sort? + (zero? (system* (string-append #+archiver "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + ;; Make sure non-ASCII file names are properly handled. + #+set-utf8-locale + + ;; Add 'tar' to the search path. + (setenv "PATH" #+(file-append archiver "/bin")) + + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; . + (populate-single-profile-directory %root + #:profile #$profile + #:profile-name #$profile-name + #:closure "profile" + #:database #+database) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) + directives) + + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (apply invoke "tar" + #+@(if (compressor-command compressor) + #~("-I" + (string-join + '#+(compressor-command compressor))) + #~()) + "--format=gnu" + ;; Avoid non-determinism in the archive. + ;; Use mtime = 1, not zero, because that is what the daemon + ;; does for files in the store (see the 'mtimeStore' constant + ;; in local-store.cc.) + (if tar-supports-sort? "--sort=name" "--mtime=@1") + "--owner=root:0" + "--group=root:0" + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + #$@(if localstatedir? + '("./var/guix") + '()) + + (string-append "." (%store-directory)) + + (delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + ((source '-> _) + (string-append "." source)) + (_ #f)) + directives))))))) - (define %root "root") - - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownnership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) - - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) - - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 2014-07-28. For testing, we use the bootstrap tar, which is - ;; older and doesn't support it. - (define tar-supports-sort? - (zero? (system* (string-append #+archiver "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - ;; Make sure non-ASCII file names are properly handled. - #+set-utf8-locale - - ;; Add 'tar' to the search path. - (setenv "PATH" #+(file-append archiver "/bin")) - - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs - ;; with hard links: - ;; . - (populate-single-profile-directory %root - #:profile #$profile - #:profile-name #$profile-name - #:closure "profile" - #:database #+database) - - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (exit - (zero? (apply system* "tar" - #+@(if (compressor-command compressor) - #~("-I" - (string-join - '#+(compressor-command compressor))) - #~()) - "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - (if tar-supports-sort? "--sort=name" "--mtime=@1") - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - #$@(if localstatedir? - '("./var/guix") - '()) - - (string-append "." (%store-directory)) - - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives))))))))) +(define* (self-contained-tarball name profile + #:key target + (profile-name "guix-profile") + deduplicate? + entry-point + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (archiver tar)) + "Return a self-contained tarball containing a store initialized with the +closure of PROFILE, a derivation. The tarball contains /gnu/store; if +LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db +with a properly initialized store database. +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the pack." (when entry-point (warning (G_ "entry point not supported in the '~a' format~%") 'tarball)) - (gexp->derivation (string-append name ".tar" - (compressor-extension compressor)) - build - #:target target - #:references-graphs `(("profile" ,profile)))) + (gexp->derivation + (string-append name ".tar" + (compressor-extension compressor)) + (self-contained-tarball/builder profile + #:profile-name profile-name + #:compressor compressor + #:localstatedir? localstatedir? + #:symlinks symlinks + #:archiver archiver) + #:target target + #:references-graphs `(("profile" ,profile)))) (define (singularity-environment-file profile) "Return a shell script that defines the environment variables corresponding -- cgit v1.2.3 From 7708c0b5e3363e7551da6127268a08b0232061f9 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 21 Jun 2021 00:33:28 -0400 Subject: pack: Factorize base tar options. * guix/docker.scm (%tar-determinism-options): Move to a new module and rename to `tar-base-options'. Adjust references accordingly. * guix/build/pack.scm: New file. * Makefile.am (MODULES): Register it. * guix/scripts/pack.scm (self-contained-tarball/builder): Use it. --- Makefile.am | 1 + guix/build/pack.scm | 52 +++++++++++++++++++++++++++++++++ guix/docker.scm | 20 ++----------- guix/scripts/pack.scm | 81 ++++++++++++++++++++------------------------------- 4 files changed, 87 insertions(+), 67 deletions(-) create mode 100644 guix/build/pack.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index dd34447020..46414b011a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -220,6 +220,7 @@ MODULES = \ guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ guix/build/json.scm \ + guix/build/pack.scm \ guix/build/utils.scm \ guix/build/union.scm \ guix/build/profiles.scm \ diff --git a/guix/build/pack.scm b/guix/build/pack.scm new file mode 100644 index 0000000000..05c7a3c594 --- /dev/null +++ b/guix/build/pack.scm @@ -0,0 +1,52 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Maxim Cournoyer +;;; +;;; 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 build pack) + #:use-module (guix build utils) + #:export (tar-base-options)) + +(define* (tar-base-options #:key tar compressor) + "Return the base GNU tar options required to produce deterministic archives +deterministically. When TAR, a GNU tar command file name, is provided, the +`--sort' option is used only if supported. When COMPRESSOR, a command such as +'(\"gzip\" \"-9n\"), is provided, the compressor is explicitly specified via +the `-I' option." + (define (tar-supports-sort? tar) + (zero? (system* tar "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + `(,@(if compressor + (list "-I" (string-join compressor)) + '()) + ;; The --sort option was added to GNU tar in version 1.28, released + ;; 2014-07-28. For testing, we use the bootstrap tar, which is older + ;; and doesn't support it. + ,@(if (and=> tar tar-supports-sort?) + '("--sort=name") + '()) + ;; Use GNU format so there's no file name length limitation. + "--format=gnu" + "--mtime=@1" + "--owner=root:0" + "--group=root:0" + ;; The 'nlink' of the store item files leads tar to store hard links + ;; instead of actual copies. However, the 'nlink' count depends on + ;; deduplication in the store; it's an "implicit input" to the build + ;; process. Use '--hard-dereference' to eliminate it. + "--hard-dereference" + "--check-links")) diff --git a/guix/docker.scm b/guix/docker.scm index 889aaeacb5..bd952e45ec 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -21,6 +21,7 @@ (define-module (guix docker) #:use-module (gcrypt hash) #:use-module (guix base16) + #:use-module (guix build pack) #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively @@ -110,18 +111,6 @@ (define* (config layer time arch #:key entry-point (environment '())) (rootfs . ((type . "layers") (diff_ids . #(,(layer-diff-id layer))))))) -(define %tar-determinism-options - ;; GNU tar options to produce archives deterministically. - '("--sort=name" "--mtime=@1" - "--owner=root:0" "--group=root:0" - - ;; When 'build-docker-image' is passed store items, the 'nlink' of the - ;; files therein leads tar to store hard links instead of actual copies. - ;; However, the 'nlink' count depends on deduplication in the store; it's - ;; an "implicit input" to the build process. '--hard-dereference' - ;; eliminates it. - "--hard-dereference")) - (define directive-file ;; Return the file or directory created by a 'evaluate-populate-directive' ;; directive. @@ -238,7 +227,7 @@ (define transformation-options (apply invoke "tar" "-cf" "../layer.tar" `(,@transformation-options - ,@%tar-determinism-options + ,@(tar-base-options) ,@paths ,@(scandir "." (lambda (file) @@ -273,9 +262,6 @@ (define transformation-options (scm->json (repositories prefix id repository))))) (apply invoke "tar" "-cf" image "-C" directory - `(,@%tar-determinism-options - ,@(if compressor - (list "-I" (string-join compressor)) - '()) + `(,@(tar-base-options #:compressor compressor) ".")) (delete-file-recursively directory))) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index ac477850e6..d11f498925 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -205,12 +205,14 @@ (define (import-module? module) (not (equal? '(guix store deduplication) module)))) (with-imported-modules (source-module-closure - `((guix build utils) + `((guix build pack) + (guix build utils) (guix build union) (gnu build install)) #:select? import-module?) #~(begin - (use-modules (guix build utils) + (use-modules (guix build pack) + (guix build utils) ((guix build union) #:select (relative-file-name)) (gnu build install) (srfi srfi-1) @@ -240,19 +242,10 @@ (define directives ;; Fully-qualified symlinks. (append-map symlink->directives '#$symlinks)) - ;; The --sort option was added to GNU tar in version 1.28, released - ;; 2014-07-28. For testing, we use the bootstrap tar, which is - ;; older and doesn't support it. - (define tar-supports-sort? - (zero? (system* (string-append #+archiver "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - ;; Make sure non-ASCII file names are properly handled. #+set-utf8-locale - ;; Add 'tar' to the search path. - (setenv "PATH" #+(file-append archiver "/bin")) + (define tar #+(file-append archiver "/bin/tar")) ;; Note: there is not much to gain here with deduplication and there ;; is the overhead of the '.links' directory, so turn it off. @@ -269,45 +262,33 @@ (define tar-supports-sort? (for-each (cut evaluate-populate-directive <> %root) directives) - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. + ;; Create the tarball. (with-directory-excursion %root - (apply invoke "tar" - #+@(if (compressor-command compressor) - #~("-I" - (string-join - '#+(compressor-command compressor))) - #~()) - "--format=gnu" - ;; Avoid non-determinism in the archive. - ;; Use mtime = 1, not zero, because that is what the daemon - ;; does for files in the store (see the 'mtimeStore' constant - ;; in local-store.cc.) - (if tar-supports-sort? "--sort=name" "--mtime=@1") - "--owner=root:0" - "--group=root:0" - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - #$@(if localstatedir? - '("./var/guix") - '()) - - (string-append "." (%store-directory)) - - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives))))))) + (apply invoke tar + `(,@(tar-base-options + #:tar tar + #:compressor '#+(and=> compressor compressor-command)) + "-cvf" ,#$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + ,#$@(if localstatedir? + '("./var/guix") + '()) + + ,(string-append "." (%store-directory)) + + ,@(delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + ((source '-> _) + (string-append "." source)) + (_ #f)) + directives)))))))) (define* (self-contained-tarball name profile #:key target -- cgit v1.2.3 From f72aa3834b83d4c5e6889aa7698d4bff16e53984 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 17 Jun 2021 01:20:29 -0400 Subject: pack: Fix typo. * guix/scripts/pack.scm (self-contained-tarball/builder): Fix typo. --- guix/scripts/pack.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index d11f498925..7ea97a4b7a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -229,7 +229,7 @@ (define symlink->directives (let ((target (string-append #$profile "/" target)) (parent (dirname source))) ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownnership when extracting the archive (see + ;; preserve its ownership when extracting the archive (see ;; below), and also because this would lead to adding the ;; same entries twice in the tarball. `(,@(if (string=? parent "/") -- cgit v1.2.3 From 6b0e55cde901dd5f6eae72cee10723b7739cadf7 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 17 Jun 2021 15:09:46 -0400 Subject: pack: Improve naming of the packs store file names. Instead of just naming them by their pack type, add information from the package(s) they contain to make it easier to differentiate them. * guix/scripts/pack.scm (define-with-source): New macro. (manifest->friendly-name): Extract procedure from ... (docker-image): ... here, now defined via the above macro. Adjust REPOSITORY argument value accordingly. (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME. --- guix/scripts/pack.scm | 49 +++++++++++++++++++++++++++++++------------------ 1 file changed, 31 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 7ea97a4b7a..952c1455be 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -172,6 +172,28 @@ (define db-file (computed-file "store-database" build #:options `(#:references-graphs ,(zip labels items)))) +(define-syntax-rule (define-with-source (variable args ...) body body* ...) + "Bind VARIABLE to a procedure accepting ARGS defined as BODY, also setting +its source property." + (begin + (define (variable args ...) + body body* ...) + (eval-when (load eval) + (set-procedure-property! variable 'source + '(define (variable args ...) body body* ...))))) + +(define-with-source (manifest->friendly-name manifest) + "Return a friendly name computed from the entries in MANIFEST, a + object." + (let loop ((names (map manifest-entry-name + (manifest-entries manifest)))) + (define str (string-join names "-")) + (if (< (string-length str) 40) + str + (match names + ((_) str) + ((names ... _) (loop names)))))) + ;;; ;;; Tarball format. @@ -540,7 +562,7 @@ (define database (file-append (store-database (list profile)) "/db/db.sqlite"))) - (define defmod 'define-module) ;trick Geiser + (define defmod 'define-module) ;trick Geiser (define build ;; Guile-JSON and Guile-Gcrypt are required by (guix docker). @@ -558,6 +580,8 @@ (define build (srfi srfi-1) (srfi srfi-19) (ice-9 match)) + #$(procedure-source manifest->friendly-name) + (define environment (map (match-lambda ((spec . value) @@ -581,19 +605,6 @@ (define directives `((directory "/tmp" ,(getuid) ,(getgid) #o1777) ,@(append-map symlink->directives '#$symlinks))) - (define tag - ;; Compute a meaningful "repository" name, which will show up in - ;; the output of "docker images". - (let ((manifest (profile-manifest #$profile))) - (let loop ((names (map manifest-entry-name - (manifest-entries manifest)))) - (define str (string-join names "-")) - (if (< (string-length str) 40) - str - (match names - ((_) str) - ((names ... _) (loop names))))))) ;drop one entry - (setenv "PATH" #+(file-append archiver "/bin")) (build-docker-image #$output @@ -601,7 +612,8 @@ (define str (string-join names "-")) (call-with-input-file "profile" read-reference-graph)) #$profile - #:repository tag + #:repository (manifest->friendly-name + (profile-manifest #$profile)) #:database #+database #:system (or #$target %host-type) #:environment environment @@ -1209,8 +1221,6 @@ (define with-provenance manifest) manifest))) (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) (compressor (if bootstrap? @@ -1244,7 +1254,10 @@ (define with-provenance (hooks (if bootstrap? '() %default-profile-hooks)) - (locales? (not bootstrap?))))) + (locales? (not bootstrap?)))) + (name (string-append (manifest->friendly-name manifest) + "-" (symbol->string pack-format) + "-pack"))) (define (lookup-package package) (manifest-lookup manifest (manifest-pattern (name package)))) -- cgit v1.2.3 From 4f3bdc8f21657dbda857027b3ec8754dd4c7c67b Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 17 Jun 2021 01:22:35 -0400 Subject: pack: Prevent duplicate files in tar archives. Tar translate duplicate files in the archive into hard links. These can cause problems, as not every tool support them; for example dpkg doesn't. * gnu/system/file-systems.scm (reduce-directories): New procedure. (file-prefix?): Lift the restriction on file prefix. The procedure can be useful for comparing relative file names. Adjust doc. (file-name-depth): New procedure, extracted from ... (btrfs-store-subvolume-file-name): ... here. * guix/scripts/pack.scm (self-contained-tarball/builder): Use reduce-directories. * tests/file-systems.scm ("reduce-directories"): New test. --- gnu/system/file-systems.scm | 56 ++++++++++++++++++++++++++++++--------------- guix/scripts/pack.scm | 6 +++-- tests/file-systems.scm | 7 +++++- 3 files changed, 48 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 464e87cb18..fb87bfc85b 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -55,6 +55,7 @@ (define-module (gnu system file-systems) file-system-dependencies file-system-location + reduce-directories file-system-type-predicate btrfs-subvolume? btrfs-store-subvolume-file-name @@ -231,8 +232,8 @@ (define %not-slash (char-set-complement (char-set #\/))) (define (file-prefix? file1 file2) - "Return #t if FILE1 denotes the name of a file that is a parent of FILE2, -where both FILE1 and FILE2 are absolute file name. For example: + "Return #t if FILE1 denotes the name of a file that is a parent of FILE2. +For example: (file-prefix? \"/gnu\" \"/gnu/store\") => #t @@ -240,19 +241,41 @@ (define (file-prefix? file1 file2) (file-prefix? \"/gn\" \"/gnu/store\") => #f " - (and (string-prefix? "/" file1) - (string-prefix? "/" file2) - (let loop ((file1 (string-tokenize file1 %not-slash)) - (file2 (string-tokenize file2 %not-slash))) - (match file1 - (() - #t) - ((head1 tail1 ...) - (match file2 - ((head2 tail2 ...) - (and (string=? head1 head2) (loop tail1 tail2))) - (() - #f))))))) + (let loop ((file1 (string-tokenize file1 %not-slash)) + (file2 (string-tokenize file2 %not-slash))) + (match file1 + (() + #t) + ((head1 tail1 ...) + (match file2 + ((head2 tail2 ...) + (and (string=? head1 head2) (loop tail1 tail2))) + (() + #f)))))) + +(define (file-name-depth file-name) + (length (string-tokenize file-name %not-slash))) + +(define (reduce-directories file-names) + "Eliminate entries in FILE-NAMES that are children of other entries in +FILE-NAMES. This is for example useful when passing a list of files to GNU +tar, which would otherwise descend into each directory passed and archive the +duplicate files as hard links, which can be undesirable." + (let* ((file-names/sorted + ;; Ascending sort by file hierarchy depth, then by file name length. + (stable-sort (delete-duplicates file-names) + (lambda (f1 f2) + (let ((depth1 (file-name-depth f1)) + (depth2 (file-name-depth f2))) + (if (= depth1 depth2) + (string< f1 f2) + (< depth1 depth2))))))) + (reverse (fold (lambda (file-name results) + (if (find (cut file-prefix? <> file-name) results) + results ;parent found -- skipping + (cons file-name results))) + '() + file-names/sorted)))) (define* (file-system-device->string device #:key uuid-type) "Return the string representations of the DEVICE field of a @@ -624,9 +647,6 @@ (define (prepend-slash/maybe s) s (string-append "/" s))) - (define (file-name-depth file-name) - (length (string-tokenize file-name %not-slash))) - (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems)) (btrfs-subvolume-fs* (sort btrfs-subvolume-fs diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 952c1455be..cee1444110 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -230,13 +230,15 @@ (define (import-module? module) `((guix build pack) (guix build utils) (guix build union) - (gnu build install)) + (gnu build install) + (gnu system file-systems)) #:select? import-module?) #~(begin (use-modules (guix build pack) (guix build utils) ((guix build union) #:select (relative-file-name)) (gnu build install) + ((gnu system file-systems) #:select (reduce-directories)) (srfi srfi-1) (srfi srfi-26) (ice-9 match)) @@ -303,7 +305,7 @@ (define tar #+(file-append archiver "/bin/tar")) ,(string-append "." (%store-directory)) - ,@(delete-duplicates + ,@(reduce-directories (filter-map (match-lambda (('directory directory) (string-append "." directory)) diff --git a/tests/file-systems.scm b/tests/file-systems.scm index 7f7c373884..80acb6d5b9 100644 --- a/tests/file-systems.scm +++ b/tests/file-systems.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Ludovic Courtès -;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2020, 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,6 +50,11 @@ (define-module (test-file-systems) (device "/foo") (flags '(bind-mount read-only))))))))) +(test-equal "reduce-directories" + '("./opt/gnu/" "./opt/gnuism" "a/b/c") + (reduce-directories '("./opt/gnu/etc" "./opt/gnu/" "./opt/gnu/bin" + "./opt/gnu/lib/debug" "./opt/gnuism" "a/b/c" "a/b/c"))) + (test-assert "does not pull (guix config)" ;; This module is meant both for the host side and "build side", so make ;; sure it doesn't pull in (guix config), which depends on the user's -- cgit v1.2.3 From 82daab42811a2e3c7684ebdf12af75ff0fa67b99 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 15 Jun 2021 10:21:50 -0400 Subject: pack: Add support for the deb format. * .dir-locals.el (scheme-mode)[gexp->derivation]: Define indentation rule. * guix/scripts/pack.scm (debian-archive): New procedure. (%formats): Register the new deb format. (show-formats): Add it to the usage string. * tests/pack.scm (%ar-bootstrap): New variable. (deb archive with symlinks): New test. * doc/guix.texi (Invoking guix pack): Document it. * NEWS: Add news entry. --- .dir-locals.el | 1 + NEWS | 7 +- doc/guix.texi | 5 ++ guix/scripts/pack.scm | 180 +++++++++++++++++++++++++++++++++++++++++++++++++- tests/pack.scm | 75 +++++++++++++++++++++ 5 files changed, 265 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 8f07a08eb5..a4fcbfe7ca 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -75,6 +75,7 @@ (eval . (put 'origin 'scheme-indent-function 0)) (eval . (put 'build-system 'scheme-indent-function 0)) (eval . (put 'bag 'scheme-indent-function 0)) + (eval . (put 'gexp->derivation 'scheme-indent-function 1)) (eval . (put 'graft 'scheme-indent-function 0)) (eval . (put 'operating-system 'scheme-indent-function 0)) (eval . (put 'file-system 'scheme-indent-function 0)) diff --git a/NEWS b/NEWS index 1d3f5aaffd..b0647b3700 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,7 @@ Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès Copyright © 2016, 2017, 2018 Ricardo Wurmus +Copyright © 2021 Maxim Cournoyer Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright @@ -11,10 +12,12 @@ Copyright © 2016, 2017, 2018 Ricardo Wurmus Please send Guix bug reports to bug-guix@gnu.org. -* Changes in 1.3.0 (since 1.2.0) - +* Changes in 1.4.0 (since 1.3.0) ** Package management + * New 'deb' format for the 'guix pack' command +* Changes in 1.3.0 (since 1.2.0) +** Package management *** POWER9 (powerpc64le-linux) is now supported as a technology preview *** New ‘--export-manifest’ and ‘--export-channels’ options of ‘guix package’ *** New ‘--profile’ option for ‘guix environment’ diff --git a/doc/guix.texi b/doc/guix.texi index 37936bb0f3..e0668b1f5f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6028,6 +6028,11 @@ This produces a SquashFS image containing all the specified binaries and symlinks, as well as empty mount points for virtual file systems like procfs. +@item deb +This produces a Debian archive (a package with the @samp{.deb} file +extension) containing all the specified binaries and symbolic links, +that can be installed on top of any dpkg-based GNU/Linux distribution. + @quotation Note Singularity @emph{requires} you to provide @file{/bin/sh} in the image. For that reason, @command{guix pack -f squashfs} always implies @code{-S diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index cee1444110..6d8b70d1c7 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2018 Efraim Flashner ;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; Copyright © 2020 Eric Bavier +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -65,6 +66,7 @@ (define-module (guix scripts pack) %compressors lookup-compressor self-contained-tarball + debian-archive docker-image squashfs-image @@ -346,6 +348,10 @@ (define* (self-contained-tarball name profile #:target target #:references-graphs `(("profile" ,profile)))) + +;;; +;;; Singularity. +;;; (define (singularity-environment-file profile) "Return a shell script that defines the environment variables corresponding to the search paths of PROFILE." @@ -372,6 +378,10 @@ (define build (computed-file "singularity-environment.sh" build)) + +;;; +;;; SquashFS image format. +;;; (define* (squashfs-image name profile #:key target (profile-name "guix-profile") @@ -546,6 +556,10 @@ (define (mksquashfs args) #:target target #:references-graphs `(("profile" ,profile)))) + +;;; +;;; Docker image format. +;;; (define* (docker-image name profile #:key target (profile-name "guix-profile") @@ -633,6 +647,167 @@ (define directives #:target target #:references-graphs `(("profile" ,profile)))) + +;;; +;;; Debian archive format. +;;; +;;; TODO: When relocatable option is selected, install to a unique prefix. +;;; This would enable installation of multiple deb packs with conflicting +;;; files at the same time. +;;; TODO: Allow passing a custom control file from the CLI. +;;; TODO: Allow providing a postinst script. +(define* (debian-archive name profile + #:key target + (profile-name "guix-profile") + deduplicate? + entry-point + (compressor (first %compressors)) + localstatedir? + (symlinks '()) + (archiver tar)) + "Return a Debian archive (.deb) containing a store initialized with the +closure of PROFILE, a derivation. The archive contains /gnu/store; if +LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db +with a properly initialized store database. The supported compressors are +\"none\", \"gz\" or \"xz\". + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the pack." + ;; For simplicity, limit the supported compressors to the superset of + ;; compressors able to compress both the control file (gz or xz) and the + ;; data tarball (gz, bz2 or xz). + (define %valid-compressors '("gzip" "xz" "none")) + + (let ((compressor-name (compressor-name compressor))) + (unless (member compressor-name %valid-compressors) + (leave (G_ "~a is not a valid Debian archive compressor. \ +Valid compressors are: ~a~%") compressor-name %valid-compressors))) + + (when entry-point + (warning (G_ "entry point not supported in the '~a' format~%") + 'deb)) + + (define data-tarball + (computed-file (string-append "data.tar" + (compressor-extension compressor)) + (self-contained-tarball/builder + profile + #:profile-name profile-name + #:compressor compressor + #:localstatedir? localstatedir? + #:symlinks symlinks + #:archiver archiver) + #:local-build? #f ;allow offloading + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) + + (define build + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((guix build pack) + (guix build utils) + (guix profiles)) + #:select? not-config?)) + #~(begin + (use-modules (guix build pack) + (guix build utils) + (guix profiles) + (ice-9 match) + (srfi srfi-1)) + + (define machine-type + ;; Extract the machine type from the specified target, else from the + ;; current system. + (and=> (or #$target %host-type) (lambda (triplet) + (first (string-split triplet #\-))))) + + (define (gnu-machine-type->debian-machine-type type) + "Translate machine TYPE from the GNU to Debian terminology." + ;; Debian has its own jargon, different from the one used in GNU, for + ;; machine types (see data/cputable in the sources of dpkg). + (match type + ("i586" "i386") + ("i486" "i386") + ("i686" "i386") + ("x86_64" "amd64") + ("aarch64" "arm64") + ("mipsisa32r6" "mipsr6") + ("mipsisa32r6el" "mipsr6el") + ("mipsisa64r6" "mips64r6") + ("mipsisa64r6el" "mips64r6el") + ("powerpcle" "powerpcel") + ("powerpc64" "ppc64") + ("powerpc64le" "ppc64el") + (machine machine))) + + (define architecture + (gnu-machine-type->debian-machine-type machine-type)) + + #$(procedure-source manifest->friendly-name) + + (define manifest (profile-manifest #$profile)) + + (define single-entry ;manifest entry + (match (manifest-entries manifest) + ((entry) + entry) + (() #f))) + + (define package-name (or (and=> single-entry manifest-entry-name) + (manifest->friendly-name manifest))) + + (define package-version + (or (and=> single-entry manifest-entry-version) + "0.0.0")) + + (define debian-format-version "2.0") + + ;; Generate the debian-binary file. + (call-with-output-file "debian-binary" + (lambda (port) + (format port "~a~%" debian-format-version))) + + (define data-tarball-file-name (strip-store-file-name + #+data-tarball)) + + (copy-file #+data-tarball data-tarball-file-name) + + (define control-tarball-file-name + (string-append "control.tar" + #$(compressor-extension compressor))) + + ;; Write the compressed control tarball. Only the control file is + ;; mandatory (see: 'man deb' and 'man deb-control'). + (call-with-output-file "control" + (lambda (port) + (format port "\ +Package: ~a +Version: ~a +Description: Debian archive generated by GNU Guix. +Maintainer: GNU Guix +Architecture: ~a +~%" package-name package-version architecture))) + + (define tar (string-append #+archiver "/bin/tar")) + + (apply invoke tar + `(,@(tar-base-options + #:tar tar + #:compressor '#+(and=> compressor compressor-command)) + "-cvf" ,control-tarball-file-name + "control")) + + ;; Create the .deb archive using GNU ar. + (invoke (string-append #+binutils "/bin/ar") "-rv" #$output + "debian-binary" + control-tarball-file-name data-tarball-file-name))))) + + (gexp->derivation (string-append name ".deb") + build + #:target target + #:references-graphs `(("profile" ,profile)))) + ;;; ;;; Compiling C programs. @@ -965,7 +1140,8 @@ (define %formats ;; Supported pack formats. `((tarball . ,self-contained-tarball) (squashfs . ,squashfs-image) - (docker . ,docker-image))) + (docker . ,docker-image) + (deb . ,debian-archive))) (define (show-formats) ;; Print the supported pack formats. @@ -977,6 +1153,8 @@ (define (show-formats) squashfs Squashfs image suitable for Singularity")) (display (G_ " docker Tarball ready for 'docker load'")) + (display (G_ " + deb Debian archive installable via dpkg/apt")) (newline)) (define %options diff --git a/tests/pack.scm b/tests/pack.scm index ae6247a1d5..9473d4f384 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ (define-module (test-pack) #:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages compression) #:select (squashfs-tools)) + #:use-module ((gnu packages debian) #:select (dpkg)) #:use-module ((gnu packages guile) #:select (guile-sqlite3)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) #:use-module (srfi srfi-64)) @@ -56,6 +58,8 @@ (define %gzip-compressor (define %tar-bootstrap %bootstrap-coreutils&co) +(define %ar-bootstrap %bootstrap-binutils) + (test-begin "pack") @@ -270,6 +274,77 @@ (define bin 1) (pk 'guilelink (readlink "bin")))) (mkdir #$output)))))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "deb archive with symlinks" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (deb (debian-archive "deb-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/opt/gnu/bin" -> "bin")) + #:archiver %tar-bootstrap)) + (check + (gexp->derivation "check-deb-pack" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match) + (ice-9 popen) + (ice-9 rdelim) + (ice-9 textual-ports) + (rnrs base)) + + (setenv "PATH" (string-join + (list (string-append #+%tar-bootstrap "/bin") + (string-append #+dpkg "/bin") + (string-append #+%ar-bootstrap "/bin")) + ":")) + + ;; Validate the output of 'dpkg --info'. + (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb)) + (info (get-string-all port)) + (exit-val (status:exit-val (close-pipe port)))) + (assert (zero? exit-val)) + + (assert (string-contains + info + (string-append "Package: " + #+(package-name %bootstrap-guile)))) + + (assert (string-contains + info + (string-append "Version: " + #+(package-version %bootstrap-guile))))) + + ;; Sanity check .deb contents. + (invoke "ar" "-xv" #$deb) + (assert (file-exists? "debian-binary")) + (assert (file-exists? "data.tar.gz")) + (assert (file-exists? "control.tar.gz")) + + ;; Verify there are no hard links in data.tar.gz, as hard + ;; links would cause dpkg to fail unpacking the archive. + (define hard-links + (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz"))) + (let loop ((hard-links '())) + (match (read-line port) + ((? eof-object?) + (assert (zero? (status:exit-val (close-pipe port)))) + hard-links) + (line + (if (string-prefix? "u" line) + (loop (cons line hard-links)) + (loop hard-links))))))) + + (unless (null? hard-links) + (error "hard links found in data.tar.gz" hard-links)) + + (mkdir #$output)))))) (built-derivations (list check))))) (test-end) -- cgit v1.2.3 From d9e0ae07db5cb9f949c11f4ee77146a070c2618c Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Mon, 28 Jun 2021 19:24:44 +0200 Subject: guix: gexp: Define gexp->approximate-sexp. It will be used in the 'optional-tests' linter. * guix/gexp.scm (gexp->approximate-sexp): New procedure. * tests/gexp.scm ("no references", "unquoted gexp", "unquoted gexp (native)") ("spliced gexp", "unspliced gexp, approximated") ("unquoted gexp, approximated"): Test it. * doc/gexp.scm ("G-Expressions"): Document it. Signed-off-by: Mathieu Othacehe --- doc/guix.texi | 10 ++++++++++ guix/gexp.scm | 19 +++++++++++++++++++ tests/gexp.scm | 31 +++++++++++++++++++++++++++++++ 3 files changed, 60 insertions(+) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index e0668b1f5f..e39e4eb7be 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10046,6 +10046,16 @@ corresponding to @var{obj} for @var{system}, cross-compiling for has an associated gexp compiler, such as a @code{}. @end deffn +@deffn {Procedure} gexp->approximate-sexp @var{gexp} +Sometimes, it may be useful to convert a G-exp into a S-exp. For +example, some linters (@pxref{Invoking guix lint}) peek into the build +phases of a package to detect potential problems. This conversion can +be achieved with this procedure. However, some information can be lost +in the process. More specifically, lowerable objects will be silently +replaced with some arbitrary object -- currently the list +@code{(*approximate*)}, but this may change. +@end deffn + @node Invoking guix repl @section Invoking @command{guix repl} diff --git a/guix/gexp.scm b/guix/gexp.scm index 187f5c5e85..f3d278b3e6 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Jan Nieuwenhuizen ;;; Copyright © 2019, 2020 Mathieu Othacehe ;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +43,7 @@ (define-module (guix gexp) with-imported-modules with-extensions let-system + gexp->approximate-sexp gexp-input gexp-input? @@ -157,6 +159,23 @@ (define (gexp-location gexp) "Return the source code location of GEXP." (and=> (%gexp-location gexp) source-properties->location)) +(define* (gexp->approximate-sexp gexp) + "Return the S-expression corresponding to GEXP, but do not lower anything. +As a result, the S-expression will be approximate if GEXP has references." + (define (gexp-like? thing) + (or (gexp? thing) (gexp-input? thing))) + (apply (gexp-proc gexp) + (map (lambda (reference) + (match reference + (($ thing output native) + (if (gexp-like? thing) + (gexp->approximate-sexp thing) + ;; Simply returning 'thing' won't work in some + ;; situations; see 'write-gexp' below. + '(*approximate*))) + (_ '(*approximate*)))) + (gexp-references gexp)))) + (define (write-gexp gexp port) "Write GEXP on PORT." (display "# +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -89,6 +90,36 @@ (define defmod 'define-module) ;fool Geiser (test-begin "gexp") +(test-equal "no references" + '(display "hello gexp->approximate-sexp!") + (gexp->approximate-sexp #~(display "hello gexp->approximate-sexp!"))) + +(test-equal "unquoted gexp" + '(display "hello") + (let ((inside #~"hello")) + (gexp->approximate-sexp #~(display #$inside)))) + +(test-equal "unquoted gexp (native)" + '(display "hello") + (let ((inside #~"hello")) + (gexp->approximate-sexp #~(display #+inside)))) + +(test-equal "spliced gexp" + '(display '(fresh vegetables)) + (let ((inside #~(fresh vegetables))) + (gexp->approximate-sexp #~(display '(#$@inside))))) + +(test-equal "unspliced gexp, approximated" + ;; (*approximate*) is really an implementation detail + '(display '(*approximate*)) + (let ((inside (file-append coreutils "/bin/hello"))) + (gexp->approximate-sexp #~(display '(#$@inside))))) + +(test-equal "unquoted gexp, approximated" + '(display '(*approximate*)) + (let ((inside (file-append coreutils "/bin/hello"))) + (gexp->approximate-sexp #~(display '#$inside)))) + (test-equal "no refs" '(display "hello!") (let ((exp (gexp (display "hello!")))) -- cgit v1.2.3 From 5532371a3a25adaa023a00ae1004c2f422f3abc8 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Mon, 28 Jun 2021 20:44:16 +0200 Subject: lint: Verify if #:tests? is respected in the 'check' phase. There have been a few patches to the mailing list lately not respecting this, and this linter detects 630 package definitions that could be modified to support the --without-tests package transformation. * guix/lint.scm (check-optional-tests): New linter. (%local-checkers)[optional-tests]: Add it. * tests/lint.scm (package-with-phase-changes): New procedure. ("optional-tests: no check phase") ("optional-tests: check hase respects #:tests?") ("optional-tests: check phase ignores #:tests?") ("optional-tests: do not crash when #:phases is invalid") ("optional-tests: allow G-exps (no warning)") ("optional-tests: allow G-exps (warning)") ("optional-tests: complicated 'check' phase") ("optional-tests: 'check' phase is not first phase"): New tests. Signed-off-by: Mathieu Othacehe --- guix/lint.scm | 60 ++++++++++++++++++++++++++++++++++++++++++++- tests/lint.scm | 77 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 135 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 70ed677a54..1f48bcc454 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -40,7 +40,8 @@ (define-module (guix lint) #:use-module (guix packages) #:use-module (guix i18n) #:use-module ((guix gexp) - #:select (local-file? local-file-absolute-file-name)) + #:select (gexp? local-file? local-file-absolute-file-name + gexp->approximate-sexp)) #:use-module (guix licenses) #:use-module (guix records) #:use-module (guix grafts) @@ -89,6 +90,7 @@ (define-module (guix lint) check-source check-source-file-name check-source-unstable-tarball + check-optional-tests check-mirror-url check-github-url check-license @@ -1098,6 +1100,58 @@ (define (follow-redirects-to-github uri) (define exception-with-kind-and-args? (exception-predicate &exception-with-kind-and-args)) +(define (check-optional-tests package) + "Emit a warning if the test suite is run unconditionally." + (define (sexp-contains-atom? sexp atom) + "Test if SEXP contains ATOM." + (if (pair? sexp) + (or (sexp-contains-atom? (car sexp) atom) + (sexp-contains-atom? (cdr sexp) atom)) + (eq? sexp atom))) + (define (sexp-uses-tests?? sexp) + "Test if SEXP contains the symbol 'tests?'." + (sexp-contains-atom? sexp 'tests?)) + (define (check-check-procedure expression) + (match expression + (`(,(or 'let 'let*) . ,_) + (check-check-procedure (car (last-pair expression)))) + (`(,(or 'lambda 'lambda*) ,_ . ,code) + (if (sexp-uses-tests?? code) + '() + (list (make-warning package + ;; TRANSLATORS: check and #:tests? are a + ;; Scheme symbol and keyword respectively + ;; and should not be translated. + (G_ "the 'check' phase should respect #:tests?") + #:field 'arguments)))) + (_ '()))) + (define (check-phases-delta delta) + (match delta + (`(replace 'check ,expression) + (check-check-procedure expression)) + (_ '()))) + (define (check-phases-deltas deltas) + (match deltas + (() '()) + ((head . tail) + (append (check-phases-delta head) + (check-phases-deltas tail))) + (_ (list (make-warning package + ;; TRANSLATORS: modify-phases is a Scheme + ;; syntax and must not be translated. + (G_ "incorrect call to ‘modify-phases’") + #:field 'arguments))))) + (apply (lambda* (#:key phases #:allow-other-keys) + (define phases/sexp + (if (gexp? phases) + (gexp->approximate-sexp phases) + phases)) + (match phases/sexp + (`(modify-phases ,_ . ,changes) + (check-phases-deltas changes)) + (_ '()))) + (package-arguments package))) + (define* (check-derivation package #:key store) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try store system) @@ -1598,6 +1652,10 @@ (define %local-checkers (description "Make sure the 'license' field is a \ or a list thereof") (check check-license)) + (lint-checker + (name 'optional-tests) + (description "Make sure tests are only run when requested") + (check check-optional-tests)) (lint-checker (name 'mirror-url) (description "Suggest 'mirror://' URLs") diff --git a/tests/lint.scm b/tests/lint.scm index fae346e724..4ef400a9a0 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2018, 2019 Arun Isaac ;;; Copyright © 2020 Timothy Sample ;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,7 +39,7 @@ (define-module (test-lint) #:use-module (guix lint) #:use-module (guix ui) #:use-module (guix swh) - #:use-module ((guix gexp) #:select (local-file)) + #:use-module ((guix gexp) #:select (gexp local-file gexp?)) #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module ((guix import hackage) #:select (%hackage-url)) #:use-module ((guix import stackage) #:select (%stackage-url)) @@ -744,6 +745,80 @@ (define (warning-contains? str warnings) (sha256 %null-sha256)))))) (check-source-unstable-tarball pkg))) +(define (package-with-phase-changes changes) + (dummy-package "x" + (arguments `(#:phases + ,(if (gexp? changes) + #~(modify-phases %standard-phases + #$@changes) + `(modify-phases %standard-phases + ,@changes)))))) + +(test-equal "optional-tests: no check phase" + '() + (let ((pkg (package-with-phase-changes '()))) + (check-optional-tests pkg))) + +(test-equal "optional-tests: check phase respects #:tests?" + '() + (let ((pkg (package-with-phase-changes + '((replace 'check + (lambda* (#:key tests? #:allow-other-keys?) + (when tests? + (invoke "./the-test-suite")))))))) + (check-optional-tests pkg))) + +(test-equal "optional-tests: check phase ignores #:tests?" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + '((replace 'check + (lambda _ + (invoke "./the-test-suite"))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: do not crash when #:phases is invalid" + "incorrect call to ‘modify-phases’" + (let ((pkg (package-with-phase-changes 'this-is-not-a-list))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: allow G-exps (no warning)" + '() + (let ((pkg (package-with-phase-changes #~()))) + (check-optional-tests pkg))) + +(test-equal "optional-tests: allow G-exps (warning)" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + #~((replace 'check + (lambda _ + (invoke "/the-test-suite"))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: complicated 'check' phase" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + '((replace 'check + (lambda* (#:key inputs tests? #:allow-other-keys) + (let ((something (stuff from inputs or native-inputs))) + (delete-file "dateutil/test/test_utils.py") + (invoke "pytest" "-vv")))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + +(test-equal "optional-tests: 'check' phase is not first phase" + "the 'check' phase should respect #:tests?" + (let ((pkg (package-with-phase-changes + '((add-after 'unpack + (lambda _ + (chdir "libtestcase-0.0.0"))) + (replace 'check + (lambda _ (invoke "./test-suite"))))))) + (single-lint-warning-message + (check-optional-tests pkg)))) + (test-equal "source: 200" '() (with-http-server `((200 ,%long-string)) -- cgit v1.2.3 From 3a94998f5e1699c23fba7843ceba098aa607024d Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 2 Jul 2021 00:58:06 -0400 Subject: Revert "build-system/qt: Fix wrapping with QTWEBENGINEPROCESS_PATH." This reverts commit fed28a9632ba69225151757e44a5d70e9b0652a2. It will need to be refactored to fit on top of 2214b7b78d34a0e4d574b743dbeb8457356f6cff. --- guix/build/qt-build-system.scm | 29 +++++++++++------------------ 1 file changed, 11 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index f59b0c420f..bd8e694209 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -49,23 +49,17 @@ (define* (check-setup #:rest args) (define (variables-for-wrapping base-directories) - (define (collect-sub-dirs base-directories file-type subdirectory + (define (collect-sub-dirs base-directories subdirectory selectors) ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset ;; that exists and has at least one of the SELECTORS sub-directories, - ;; unless SELECTORS is the empty list. FILE-TYPE should by 'directory or - ;; 'regular file. For the later, it allows searching for plain files - ;; rather than directories. - (define exists? (match file-type - ('directory directory-exists?) - ('regular file-exists?))) - + ;; unless SELECTORS is the empty list. (filter-map (lambda (dir) (let ((directory (string-append dir subdirectory))) - (and (exists? directory) + (and (directory-exists? directory) (or (null? selectors) (any (lambda (selector) - (exists? + (directory-exists? (string-append directory selector))) selectors)) directory))) @@ -73,8 +67,8 @@ (define exists? (match file-type (filter-map (match-lambda - ((variable file-type directory selectors ...) - (match (collect-sub-dirs base-directories file-type directory + ((variable directory selectors ...) + (match (collect-sub-dirs base-directories directory selectors) (() #f) @@ -83,7 +77,7 @@ (define exists? (match file-type ;; These shall match the search-path-specification for Qt and KDE ;; libraries. - (list '("XDG_DATA_DIRS" directory "/share" + (list '("XDG_DATA_DIRS" "/share" ;; These are "selectors": consider /share if and only if at least ;; one of these sub-directories exist. This avoids adding @@ -91,11 +85,10 @@ (define exists? (match file-type ;; /share sub-directory. "/glib-2.0/schemas" "/sounds" "/themes" "/cursors" "/wallpapers" "/icons" "/mime") - '("XDG_CONFIG_DIRS" directory "/etc/xdg") - '("QT_PLUGIN_PATH" directory "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" directory "/lib/qt5/qml") - '("QTWEBENGINEPROCESS_PATH" regular - "/lib/qt5/libexec/QtWebEngineProcess")))) + '("XDG_CONFIG_DIRS" "/etc/xdg") + '("QT_PLUGIN_PATH" "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" "/lib/qt5/qml") + '("QTWEBENGINEPROCESS_PATH" "/lib/qt5/libexec/QtWebEngineProcess")))) (define* (wrap-all-programs #:key inputs outputs (qt-wrap-excluded-outputs '()) -- cgit v1.2.3 From 15fd870c3f46314e02a36818f7f16da0de32d421 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 2 Jul 2021 00:58:57 -0400 Subject: Revert "build-system/qt: Wrappers set 'QTWEBENGINEPROCESS_PATH' if needed." This reverts commit 06eb21856f9535ab62d0becc92b4146e0620654e. It will need to be refactored to fit on top of 2214b7b78d34a0e4d574b743dbeb8457356f6cff. --- guix/build/qt-build-system.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index bd8e694209..0d5531ce05 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -87,8 +87,7 @@ (define (collect-sub-dirs base-directories subdirectory "/cursors" "/wallpapers" "/icons" "/mime") '("XDG_CONFIG_DIRS" "/etc/xdg") '("QT_PLUGIN_PATH" "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" "/lib/qt5/qml") - '("QTWEBENGINEPROCESS_PATH" "/lib/qt5/libexec/QtWebEngineProcess")))) + '("QML2_IMPORT_PATH" "/lib/qt5/qml")))) (define* (wrap-all-programs #:key inputs outputs (qt-wrap-excluded-outputs '()) -- cgit v1.2.3 From 1879b05f90555c3401162eb7a0cc1cea0601e66c Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 2 Jul 2021 00:59:41 -0400 Subject: Revert "build-system/qt: Wrappers only include relevant directories to XDG_DATA_DIRS." This reverts commit c5fd1b0bd362f8b8578a76a26a65ba5d00d48992. It will need to be refactored on top of 2214b7b78d34a0e4d574b743dbeb8457356f6cff. --- guix/build/qt-build-system.scm | 58 ++++++++++++++---------------------------- 1 file changed, 19 insertions(+), 39 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index 0d5531ce05..005157b0a4 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Federico Beffa -;;; Copyright © 2014, 2015, 2021 Ludovic Courtès +;;; Copyright © 2014, 2015 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver ;;; Copyright © 2019, 2020 Hartmut Goebel ;;; @@ -49,45 +49,25 @@ (define* (check-setup #:rest args) (define (variables-for-wrapping base-directories) - (define (collect-sub-dirs base-directories subdirectory - selectors) - ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset - ;; that exists and has at least one of the SELECTORS sub-directories, - ;; unless SELECTORS is the empty list. - (filter-map (lambda (dir) - (let ((directory (string-append dir subdirectory))) - (and (directory-exists? directory) - (or (null? selectors) - (any (lambda (selector) - (directory-exists? - (string-append directory selector))) - selectors)) - directory))) - base-directories)) - - (filter-map - (match-lambda - ((variable directory selectors ...) - (match (collect-sub-dirs base-directories directory - selectors) - (() - #f) - (directories - `(,variable = ,directories))))) - - ;; These shall match the search-path-specification for Qt and KDE - ;; libraries. - (list '("XDG_DATA_DIRS" "/share" + (define (collect-sub-dirs base-directories subdirectory) + (filter-map + (lambda (dir) + (let ((directory (string-append dir subdirectory))) + (if (directory-exists? directory) directory #f))) + base-directories)) - ;; These are "selectors": consider /share if and only if at least - ;; one of these sub-directories exist. This avoids adding - ;; irrelevant packages to XDG_DATA_DIRS just because they have a - ;; /share sub-directory. - "/glib-2.0/schemas" "/sounds" "/themes" - "/cursors" "/wallpapers" "/icons" "/mime") - '("XDG_CONFIG_DIRS" "/etc/xdg") - '("QT_PLUGIN_PATH" "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" "/lib/qt5/qml")))) + (filter + (lambda (var-to-wrap) (not (null? (last var-to-wrap)))) + (map + (lambda (var-spec) + `(,(first var-spec) = ,(collect-sub-dirs base-directories (last var-spec)))) + (list + ;; these shall match the search-path-specification for Qt and KDE + ;; libraries + '("XDG_DATA_DIRS" "/share") + '("XDG_CONFIG_DIRS" "/etc/xdg") + '("QT_PLUGIN_PATH" "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" "/lib/qt5/qml"))))) (define* (wrap-all-programs #:key inputs outputs (qt-wrap-excluded-outputs '()) -- cgit v1.2.3 From 7e24e1e58d6f53d9c77f6015229d0c35f7e66bca Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Fri, 25 Dec 2020 23:02:18 +0100 Subject: guix: qt-build-system, qt-utils: Unify wrapping of qt-programs. Unify (guix qt-build-system wrap-all-programs) and (guix qt-utils wrap-qt-program), so both behave the same. The functions now reside in qt-utils to make them easily available for packages not using the qt-build-system. * guix/build/qt-build-system.scm (variables-for-wrapping, wrap-all-programs): Move from here ... * guix/build/qt-utils.scm (variables-for-wrapping, wrap-all-qt-programs): ... to here. Base the later on (wrap-qt-program*): New function, carved out from old wrap-all-programs. (wrap-qt-program): Base on wrap-qt-program*, change arguments in an incompatible way. * gnu/packages/bittorrent.scm (qbittorrent)[arguments]{wrap-qt}: Adjust to new interface of wrap-qt-program. * gnu/packages/finance.scm (electron-cash): Likewise. * gnu/packages/geo.scm (qgis): Likewise. * gnu/packages/password-utils.scm (qtpass): Likewise. * gnu/packages/video.scm (openshot): Likewise. * gnu/packages/web-browsers.scm (kristall): Likewise. --- gnu/packages/bittorrent.scm | 6 ++- gnu/packages/finance.scm | 8 +-- gnu/packages/geo.scm | 7 +-- gnu/packages/password-utils.scm | 6 ++- gnu/packages/video.scm | 6 ++- gnu/packages/web-browsers.scm | 5 +- guix/build-system/qt.scm | 1 + guix/build/qt-build-system.scm | 68 ++------------------------ guix/build/qt-utils.scm | 105 ++++++++++++++++++++++++++++++++-------- 9 files changed, 113 insertions(+), 99 deletions(-) (limited to 'guix') diff --git a/gnu/packages/bittorrent.scm b/gnu/packages/bittorrent.scm index 5d6a780aab..0ca60d607c 100644 --- a/gnu/packages/bittorrent.scm +++ b/gnu/packages/bittorrent.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2018 Nam Nguyen ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2019, 2020 Brett Gilio +;;; Copyright © 2020 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -448,8 +449,9 @@ (define-public qbittorrent #:phases (modify-phases %standard-phases (add-after 'install 'wrap-qt - (lambda* (#:key outputs #:allow-other-keys) - (wrap-qt-program (assoc-ref outputs "out") "qbittorrent") + (lambda* (#:key outputs inputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (wrap-qt-program "qbittorrent" #:output out #:inputs inputs)) #t))))) (native-inputs `(("pkg-config" ,pkg-config) diff --git a/gnu/packages/finance.scm b/gnu/packages/finance.scm index b3a8e2b732..76bf0dc28d 100644 --- a/gnu/packages/finance.scm +++ b/gnu/packages/finance.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2015, 2016 Andreas Enge ;;; Copyright © 2016, 2017, 2018 Efraim Flashner ;;; Copyright © 2016 Alex Griffin -;;; Copyright © 2016 Hartmut Goebel +;;; Copyright © 2016, 2020 Hartmut Goebel ;;; Copyright © 2017 Carlo Zancanaro ;;; Copyright © 2017 Theodoros Foradis ;;; Copyright © 2017 Vasile Dumitrascu @@ -618,8 +618,10 @@ (define-public electron-cash (assoc-ref inputs "libsecp256k1") "/lib/libsecp256k1.so.0'"))))) (add-after 'install 'wrap-qt - (lambda* (#:key outputs #:allow-other-keys) - (wrap-qt-program (assoc-ref outputs "out") "electron-cash")))))) + (lambda* (#:key outputs inputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (wrap-qt-program "electron-cash" #:output out #:inputs inputs)) + #t))))) (home-page "https://electroncash.org/") (synopsis "Bitcoin Cash wallet") (description diff --git a/gnu/packages/geo.scm b/gnu/packages/geo.scm index 1b4df7bc51..f07606aad9 100644 --- a/gnu/packages/geo.scm +++ b/gnu/packages/geo.scm @@ -10,7 +10,7 @@ ;;; Copyright © 2019, 2020, 2021 Guillaume Le Vaillant ;;; Copyright © 2019, 2020, 2021 Efraim Flashner ;;; Copyright © 2019 Wiktor Żelazny -;;; Copyright © 2019 Hartmut Goebel +;;; Copyright © 2019, 2020 Hartmut Goebel ;;; Copyright © 2020 Marius Bakke ;;; Copyright © 2020 Christopher Baines ;;; Copyright © 2020, 2021 Felix Gruber @@ -2241,8 +2241,9 @@ (define-public qgis (add-after 'install 'wrap-python (assoc-ref python:%standard-phases 'wrap)) (add-after 'wrap-python 'wrap-qt - (lambda* (#:key outputs #:allow-other-keys) - (wrap-qt-program (assoc-ref outputs "out") "qgis") + (lambda* (#:key outputs inputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (wrap-qt-program "qgis" #:output out #:inputs inputs)) #t)) (add-after 'wrap-qt 'wrap-gis (lambda* (#:key inputs outputs #:allow-other-keys) diff --git a/gnu/packages/password-utils.scm b/gnu/packages/password-utils.scm index 9c8912c5e8..b79701851f 100644 --- a/gnu/packages/password-utils.scm +++ b/gnu/packages/password-utils.scm @@ -31,6 +31,7 @@ ;;; Copyright © 2020 Vinicius Monego ;;; Copyright © 2021 Stefan Reichör ;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2020 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -682,8 +683,9 @@ (define-public qtpass (install-file "qtpass.1" man) #t))) (add-after 'install 'wrap-qt - (lambda* (#:key outputs #:allow-other-keys) - (wrap-qt-program (assoc-ref outputs "out") "qtpass") + (lambda* (#:key outputs inputs #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (wrap-qt-program "qtpass" #:output out #:inputs inputs)) #t)) (add-before 'check 'check-setup ;; Make Qt render "offscreen", required for tests. diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm index ae2f406e23..74c8d3b253 100644 --- a/gnu/packages/video.scm +++ b/gnu/packages/video.scm @@ -51,6 +51,7 @@ ;;; Copyright © 2021 Andrew Tropin ;;; Copyright © 2021 David Wilson ;;; Copyright © 2021 Maxim Cournoyer +;;; Copyright © 2020 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -4609,9 +4610,10 @@ (define-public openshot (setenv "HOME" "/tmp") #t)) (add-after 'install 'wrap-program - (lambda* (#:key outputs #:allow-other-keys) + (lambda* (#:key outputs inputs #:allow-other-keys) (let ((out (assoc-ref outputs "out"))) - (wrap-qt-program out "openshot-qt")) + (wrap-qt-program "openshot-qt" + #:output out #:inputs inputs)) #t))))) (home-page "https://www.openshot.org/") (synopsis "Video editor") diff --git a/gnu/packages/web-browsers.scm b/gnu/packages/web-browsers.scm index 9c6d9b1fd8..69844d71b3 100644 --- a/gnu/packages/web-browsers.scm +++ b/gnu/packages/web-browsers.scm @@ -18,6 +18,7 @@ ;;; Copyright © 2021 Cage ;;; Copyright © 2021 Benoit Joly ;;; Copyright © 2021 Alexander Krotov +;;; Copyright © 2020 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -449,9 +450,9 @@ (define-public kristall "/share/fonts/truetype/NotoColorEmoji"))) #t)) (add-after 'install 'wrap-program - (lambda* (#:key outputs #:allow-other-keys) + (lambda* (#:key outputs inputs #:allow-other-keys) (let ((out (assoc-ref outputs "out"))) - (wrap-qt-program out "kristall")) + (wrap-qt-program "kristall" #:output out #:inputs inputs)) #t))))) (native-inputs `(("breeze-stylesheet" diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index 118022ec45..1bd89bfa4d 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -53,6 +53,7 @@ (define-module (guix build-system qt) (define %qt-build-system-modules ;; Build-side modules imported and used by default. `((guix build qt-build-system) + (guix build qt-utils) ,@%cmake-build-system-modules)) (define (default-cmake) diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index 005157b0a4..a6955ce4c2 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2014 Federico Beffa ;;; Copyright © 2014, 2015 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver -;;; Copyright © 2019, 2020 Hartmut Goebel +;;; Copyright © 2019, 2020, 2021 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ (define-module (guix build qt-build-system) #:use-module ((guix build cmake-build-system) #:prefix cmake:) #:use-module (guix build utils) + #:use-module (guix build qt-utils) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 ftw) @@ -47,73 +48,10 @@ (define* (check-setup #:rest args) (setenv "CTEST_OUTPUT_ON_FAILURE" "1") #t) -(define (variables-for-wrapping base-directories) - - (define (collect-sub-dirs base-directories subdirectory) - (filter-map - (lambda (dir) - (let ((directory (string-append dir subdirectory))) - (if (directory-exists? directory) directory #f))) - base-directories)) - - (filter - (lambda (var-to-wrap) (not (null? (last var-to-wrap)))) - (map - (lambda (var-spec) - `(,(first var-spec) = ,(collect-sub-dirs base-directories (last var-spec)))) - (list - ;; these shall match the search-path-specification for Qt and KDE - ;; libraries - '("XDG_DATA_DIRS" "/share") - '("XDG_CONFIG_DIRS" "/etc/xdg") - '("QT_PLUGIN_PATH" "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" "/lib/qt5/qml"))))) - -(define* (wrap-all-programs #:key inputs outputs - (qt-wrap-excluded-outputs '()) - #:allow-other-keys) - "Implement phase \"qt-wrap\": look for GSettings schemas and -gtk+-v.0 libraries and create wrappers with suitably set environment variables -if found. - -Wrapping is not applied to outputs whose name is listed in -QT-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not -to contain any Qt binaries, and where wrapping would gratuitously -add a dependency of that output on Qt." - (define (find-files-to-wrap directory) - (append-map - (lambda (dir) - (if (directory-exists? dir) (find-files dir ".*") (list))) - (list (string-append directory "/bin") - (string-append directory "/sbin") - (string-append directory "/libexec") - (string-append directory "/lib/libexec")))) - - (define input-directories - ;; FIXME: Filter out unwanted inputs, e.g. cmake - (match inputs - (((_ . dir) ...) - dir))) - - (define handle-output - (match-lambda - ((output . directory) - (unless (member output qt-wrap-excluded-outputs) - (let ((bin-list (find-files-to-wrap directory)) - (vars-to-wrap (variables-for-wrapping - (append (list directory) - input-directories)))) - (when (not (null? vars-to-wrap)) - (for-each (cut apply wrap-program <> vars-to-wrap) - bin-list))))))) - - (for-each handle-output outputs) - #t) - (define %standard-phases (modify-phases cmake:%standard-phases (add-before 'check 'check-setup check-setup) - (add-after 'install 'qt-wrap wrap-all-programs))) + (add-after 'install 'qt-wrap wrap-all-qt-programs))) (define* (qt-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index d2486ee86c..3fbdb6be61 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven +;;; Copyright © 2019, 2020, 2021 Hartmut Goebel ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,23 +19,87 @@ (define-module (guix build qt-utils) #:use-module (guix build utils) - #:export (wrap-qt-program)) - -(define (wrap-qt-program out program) - (define (suffix env-var path) - (let ((env-val (getenv env-var))) - (if env-val (string-append env-val ":" path) path))) - - (let ((qml-path (suffix "QML2_IMPORT_PATH" - (string-append out "/lib/qt5/qml"))) - (plugin-path (suffix "QT_PLUGIN_PATH" - (string-append out "/lib/qt5/plugins"))) - (xdg-data-path (suffix "XDG_DATA_DIRS" - (string-append out "/share"))) - (xdg-config-path (suffix "XDG_CONFIG_DIRS" - (string-append out "/etc/xdg")))) - (wrap-program (string-append out "/bin/" program) - `("QML2_IMPORT_PATH" = (,qml-path)) - `("QT_PLUGIN_PATH" = (,plugin-path)) - `("XDG_DATA_DIRS" = (,xdg-data-path)) - `("XDG_CONFIG_DIRS" = (,xdg-config-path))))) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (wrap-qt-program + wrap-all-qt-programs)) + + +(define (variables-for-wrapping base-directories) + + (define (collect-sub-dirs base-directories subdirectory) + (filter-map + (lambda (dir) + (let ((directory (string-append dir subdirectory))) + (if (directory-exists? directory) directory #f))) + base-directories)) + + (filter + (lambda (var-to-wrap) (not (null? (last var-to-wrap)))) + (map + (lambda (var-spec) + `(,(first var-spec) = ,(collect-sub-dirs base-directories (last var-spec)))) + (list + ;; these shall match the search-path-specification for Qt and KDE + ;; libraries + '("XDG_DATA_DIRS" "/share") + '("XDG_CONFIG_DIRS" "/etc/xdg") + '("QT_PLUGIN_PATH" "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" "/lib/qt5/qml"))))) + + +(define* (wrap-qt-program* program #:key inputs output-dir) + + (define input-directories + ;; FIXME: Filter out unwanted inputs, e.g. cmake + (match inputs + (((_ . dir) ...) + dir))) + + (let ((vars-to-wrap (variables-for-wrapping + (cons output-dir input-directories)))) + (when (not (null? vars-to-wrap)) + (apply wrap-program program vars-to-wrap)))) + + +(define* (wrap-qt-program program-name #:key inputs output) + "Wrap the specified programm (which must reside in the OUTPUT's \"/bin\" +directory) with suitably set environment variables. + +This is like qt-build-systems's phase \"qt-wrap\", but only the named program +is wrapped." + (wrap-qt-program* (string-append output "/bin/" program-name) + #:output-dir output #:inputs inputs)) + + +(define* (wrap-all-qt-programs #:key inputs outputs + (qt-wrap-excluded-outputs '()) + #:allow-other-keys) + "Implement qt-build-systems's phase \"qt-wrap\": look for executables in +\"bin\", \"sbin\" and \"libexec\" of all outputs and create wrappers with +suitably set environment variables if found. + +Wrapping is not applied to outputs whose name is listed in +QT-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not +to contain any Qt binaries, and where wrapping would gratuitously +add a dependency of that output on Qt." + (define (find-files-to-wrap output-dir) + (append-map + (lambda (dir) + (if (directory-exists? dir) (find-files dir ".*") (list))) + (list (string-append output-dir "/bin") + (string-append output-dir "/sbin") + (string-append output-dir "/libexec") + (string-append output-dir "/lib/libexec")))) + + (define handle-output + (match-lambda + ((output . output-dir) + (unless (member output qt-wrap-excluded-outputs) + (for-each (cut wrap-qt-program* <> + #:output-dir output-dir #:inputs inputs) + (find-files-to-wrap output-dir)))))) + + (for-each handle-output outputs) + #t) -- cgit v1.2.3 From 30759c4aadf279e470e8d7f94de332a31c1b9f42 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Wed, 19 Aug 2020 10:44:27 +0200 Subject: guix: qt-utils: Wrapped executables honor user's envvars. Prior to this change, wrappers did set the specified environment variables to a fixed value, overwriting any user settings. This inhibited propagating e.g. XDG_DATA_DIRS from a profile to the application. Now user environment variables are prefixed (if the variable defines some "binary" search path, e.g. QT_PLUGIN_PATH) or suffixed (if the variable defines some config or data search path, e.g. XDG_DATA_DIRS). The code could also allow to overwrite, anyhow currently no variable is defined like this. * guix/build/qt-utils.scm (variables-for-wrapping): For each env-var to be wrapped, specify whether it should prefix, suffix or overwrite the user's variable. --- guix/build/qt-utils.scm | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index 3fbdb6be61..030059522d 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -39,14 +39,15 @@ (define (collect-sub-dirs base-directories subdirectory) (lambda (var-to-wrap) (not (null? (last var-to-wrap)))) (map (lambda (var-spec) - `(,(first var-spec) = ,(collect-sub-dirs base-directories (last var-spec)))) + (list (first var-spec) (second var-spec) + (collect-sub-dirs base-directories (third var-spec)))) (list ;; these shall match the search-path-specification for Qt and KDE ;; libraries - '("XDG_DATA_DIRS" "/share") - '("XDG_CONFIG_DIRS" "/etc/xdg") - '("QT_PLUGIN_PATH" "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" "/lib/qt5/qml"))))) + '("XDG_DATA_DIRS" suffix "/share") + '("XDG_CONFIG_DIRS" suffix "/etc/xdg") + '("QT_PLUGIN_PATH" prefix "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" prefix "/lib/qt5/qml"))))) (define* (wrap-qt-program* program #:key inputs output-dir) -- cgit v1.2.3 From 76174aa9914c55219bfb9169f7fc565edccad940 Mon Sep 17 00:00:00 2001 From: Jakub Kądziołka Date: Sun, 10 Jan 2021 18:49:12 +0100 Subject: build-system: qt: Exclude useless inputs from wrapped variables. * guix/build-system/qt.scm (qt-build)[qt-wrap-excluded-inputs]: New argument. * guix/build/qt-utils.scm (%qt-wrap-excluded-inputs): New variable. (wrap-qt-program*)[qt-wrap-excluded-inputs]: New argument. Filter excluded inputs. (wrap-qt-program)[qt-wrap-excluded-inputs]: New argument. (wrap-all-qt-programs)[qt-wrap-excluded-inputs]: New argument. Co-authored-by: Hartmut Goebel --- guix/build-system/qt.scm | 5 +++++ guix/build/qt-utils.scm | 29 ++++++++++++++++++++--------- 2 files changed, 25 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index 1bd89bfa4d..e1368db1d9 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013 Cyril Roelandt ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2019 Hartmut Goebel +;;; Copyright © 2020 Jakub Kądziołka ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,8 @@ (define-module (guix build-system qt) #:use-module (guix store) #:use-module (guix utils) + #:use-module ((guix build qt-utils) + #:select (%qt-wrap-excluded-inputs)) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) @@ -125,6 +128,7 @@ (define* (qt-build store name inputs (phases '(@ (guix build qt-build-system) %standard-phases)) (qt-wrap-excluded-outputs ''()) + (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs) (system (%current-system)) (imported-modules %qt-build-system-modules) (modules '((guix build qt-build-system) @@ -148,6 +152,7 @@ (define builder search-paths) #:phases ,phases #:qt-wrap-excluded-outputs ,qt-wrap-excluded-outputs + #:qt-wrap-excluded-inputs ,qt-wrap-excluded-inputs #:configure-flags ,configure-flags #:make-flags ,make-flags #:out-of-source? ,out-of-source? diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index 030059522d..a03b09f05e 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 David Craven ;;; Copyright © 2019, 2020, 2021 Hartmut Goebel +;;; Copyright © 2020 Jakub Kądziołka ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,8 +24,11 @@ (define-module (guix build qt-utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (wrap-qt-program - wrap-all-qt-programs)) + wrap-all-qt-programs + %qt-wrap-excluded-inputs)) +(define %qt-wrap-excluded-inputs + '(list "cmake" "extra-cmake-modules" "qttools")) (define (variables-for-wrapping base-directories) @@ -50,13 +54,16 @@ (define (collect-sub-dirs base-directories subdirectory) '("QML2_IMPORT_PATH" prefix "/lib/qt5/qml"))))) -(define* (wrap-qt-program* program #:key inputs output-dir) +(define* (wrap-qt-program* program #:key inputs output-dir + qt-wrap-excluded-inputs) (define input-directories - ;; FIXME: Filter out unwanted inputs, e.g. cmake - (match inputs - (((_ . dir) ...) - dir))) + (filter-map + (match-lambda + ((label . directory) + (and (not (member label qt-wrap-excluded-inputs)) + directory))) + inputs)) (let ((vars-to-wrap (variables-for-wrapping (cons output-dir input-directories)))) @@ -64,18 +71,21 @@ (define input-directories (apply wrap-program program vars-to-wrap)))) -(define* (wrap-qt-program program-name #:key inputs output) +(define* (wrap-qt-program program-name #:key inputs output + (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)) "Wrap the specified programm (which must reside in the OUTPUT's \"/bin\" directory) with suitably set environment variables. This is like qt-build-systems's phase \"qt-wrap\", but only the named program is wrapped." (wrap-qt-program* (string-append output "/bin/" program-name) - #:output-dir output #:inputs inputs)) + #:output-dir output #:inputs inputs + #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs)) (define* (wrap-all-qt-programs #:key inputs outputs (qt-wrap-excluded-outputs '()) + (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs) #:allow-other-keys) "Implement qt-build-systems's phase \"qt-wrap\": look for executables in \"bin\", \"sbin\" and \"libexec\" of all outputs and create wrappers with @@ -99,7 +109,8 @@ (define handle-output ((output . output-dir) (unless (member output qt-wrap-excluded-outputs) (for-each (cut wrap-qt-program* <> - #:output-dir output-dir #:inputs inputs) + #:output-dir output-dir #:inputs inputs + #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs) (find-files-to-wrap output-dir)))))) (for-each handle-output outputs) -- cgit v1.2.3 From 86c9f5a5fa60b0344d2c521f1c08a912a8cce872 Mon Sep 17 00:00:00 2001 From: Jakub Kądziołka Date: Sun, 10 Jan 2021 21:28:36 +0100 Subject: guix: qt-utils: Don't include useless inputs in wrapped variables. Include only those inputs into XDG_DATA_DIRS having some subdirectory of /share which is typically used by Qt. * guix/build/qt-utils.scm (variables-for-wrapping): Take the output directory as an argument for special handling. Check for subdirectories of /share used by Qt before including inputs in XDG_DATA_DIRS. (wrap-qt-program*): Pass the output directory to variables-for-wrapping. Co-authored-by: Hartmut Goebel --- guix/build/qt-utils.scm | 36 +++++++++++++++++++++++++++--------- 1 file changed, 27 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index a03b09f05e..8e6db10ca1 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -30,25 +30,42 @@ (define-module (guix build qt-utils) (define %qt-wrap-excluded-inputs '(list "cmake" "extra-cmake-modules" "qttools")) -(define (variables-for-wrapping base-directories) +;; NOTE: Apart from standard subdirectories of /share, Qt also provides +;; facilities for per-application data directories, such as +;; /share/quassel. Thus, we include the output directory even if it doesn't +;; contain any of the standard subdirectories. +(define (variables-for-wrapping base-directories output-directory) - (define (collect-sub-dirs base-directories subdirectory) + (define (collect-sub-dirs base-directories subdirectory-spec) (filter-map (lambda (dir) - (let ((directory (string-append dir subdirectory))) - (if (directory-exists? directory) directory #f))) + (match + subdirectory-spec + ((subdir) + (and (directory-exists? (string-append dir subdir)) + (string-append dir (car subdirectory-spec)))) + ((subdir children) + (and + (or + (and (string=? dir output-directory) + (directory-exists? (string-append dir subdir))) + (or-map + (lambda (kid) (directory-exists? (string-append dir subdir kid))) + children)) + (string-append dir subdir))))) base-directories)) (filter (lambda (var-to-wrap) (not (null? (last var-to-wrap)))) (map - (lambda (var-spec) - (list (first var-spec) (second var-spec) - (collect-sub-dirs base-directories (third var-spec)))) + (match-lambda + ((var kind . subdir-spec) + `(,var ,kind ,(collect-sub-dirs base-directories subdir-spec)))) (list ;; these shall match the search-path-specification for Qt and KDE ;; libraries - '("XDG_DATA_DIRS" suffix "/share") + '("XDG_DATA_DIRS" suffix "/share" ("/applications" "/fonts" + "/icons" "/mime")) '("XDG_CONFIG_DIRS" suffix "/etc/xdg") '("QT_PLUGIN_PATH" prefix "/lib/qt5/plugins") '("QML2_IMPORT_PATH" prefix "/lib/qt5/qml"))))) @@ -66,7 +83,8 @@ (define input-directories inputs)) (let ((vars-to-wrap (variables-for-wrapping - (cons output-dir input-directories)))) + (cons output-dir input-directories) + output-dir))) (when (not (null? vars-to-wrap)) (apply wrap-program program vars-to-wrap)))) -- cgit v1.2.3 From 20cf23e4f89ad97bd089d87b9fe2622fecd088ee Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 2 Jul 2021 13:49:00 -0400 Subject: build: qt-utils: Refactor the code to filter XDG_DATA_DIRS. This partially reinstate the reverted c5fd1b0bd362f8b8578a76a26a65ba5d00d48992. * guix/build/qt-utils.scm (variables-for-wrapping)[collect-sub-dirs]: Add 'selectors' parameter and honor it. Change caller to handle selectors. Modified-by: Maxim Cournoyer --- guix/build/qt-utils.scm | 70 +++++++++++++++++++++++++------------------------ 1 file changed, 36 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index 8e6db10ca1..9f09623ddc 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 David Craven ;;; Copyright © 2019, 2020, 2021 Hartmut Goebel ;;; Copyright © 2020 Jakub Kądziołka +;;; Copyright © 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,40 +37,41 @@ (define %qt-wrap-excluded-inputs ;; contain any of the standard subdirectories. (define (variables-for-wrapping base-directories output-directory) - (define (collect-sub-dirs base-directories subdirectory-spec) - (filter-map - (lambda (dir) - (match - subdirectory-spec - ((subdir) - (and (directory-exists? (string-append dir subdir)) - (string-append dir (car subdirectory-spec)))) - ((subdir children) - (and - (or - (and (string=? dir output-directory) - (directory-exists? (string-append dir subdir))) - (or-map - (lambda (kid) (directory-exists? (string-append dir subdir kid))) - children)) - (string-append dir subdir))))) - base-directories)) - - (filter - (lambda (var-to-wrap) (not (null? (last var-to-wrap)))) - (map - (match-lambda - ((var kind . subdir-spec) - `(,var ,kind ,(collect-sub-dirs base-directories subdir-spec)))) - (list - ;; these shall match the search-path-specification for Qt and KDE - ;; libraries - '("XDG_DATA_DIRS" suffix "/share" ("/applications" "/fonts" - "/icons" "/mime")) - '("XDG_CONFIG_DIRS" suffix "/etc/xdg") - '("QT_PLUGIN_PATH" prefix "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" prefix "/lib/qt5/qml"))))) - + (define (collect-sub-dirs base-directories subdirectory selectors) + ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset + ;; that exists and has at least one of the SELECTORS sub-directories, + ;; unless SELECTORS is the empty list. + (filter-map (lambda (dir) + (let ((directory (string-append dir subdirectory))) + (and (directory-exists? directory) + (or (null? selectors) + (any (lambda (selector) + (directory-exists? + (string-append directory selector))) + selectors)) + directory))) + base-directories)) + + (filter-map + (match-lambda + ((variable type directory selectors ...) + (match (collect-sub-dirs base-directories directory selectors) + (() + #f) + (directories + `(,variable ,type ,directories))))) + ;; These shall match the search-path-specification for Qt and KDE + ;; libraries. + (list '("XDG_DATA_DIRS" suffix "/share" + ;; These are "selectors": consider /share if and only if at least + ;; one of these sub-directories exist. This avoids adding + ;; irrelevant packages to XDG_DATA_DIRS just because they have a + ;; /share sub-directory. + "/applications" "/cursors" "/fonts" "/icons" "/glib-2.0/schemas" + "/mime" "/sounds" "/themes" "/wallpapers") + '("XDG_CONFIG_DIRS" suffix "/etc/xdg") + '("QT_PLUGIN_PATH" prefix "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" prefix "/lib/qt5/qml")))) (define* (wrap-qt-program* program #:key inputs output-dir qt-wrap-excluded-inputs) -- cgit v1.2.3 From d5c9cc6d9d979bfca5f035429bcf510a0a2285a3 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 2 Jul 2021 14:05:38 -0400 Subject: build: qt-utils: Wrappers set 'QTWEBENGINEPROCESS_PATH' if needed. This reinstate commit the reverted fed28a9632ba69225151757e44a5d70e9b0652a2, now rebased on top of conflicting changes. * guix/build/qt-utils.scm: Remove extraneous newlines. (variables-for-wrapping): Add comments. Define a file type entry for each variable definition, and use it to determine if we should look for directories versus plain files. : New environment variable. (wrap-all-qt-programs): Remove trailing #t. --- guix/build/qt-utils.scm | 54 +++++++++++++++++++++++++++++++------------------ 1 file changed, 34 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index 9f09623ddc..c2b80cab7d 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2019, 2020, 2021 Hartmut Goebel ;;; Copyright © 2020 Jakub Kądziołka ;;; Copyright © 2021 Ludovic Courtès +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,16 +38,22 @@ (define %qt-wrap-excluded-inputs ;; contain any of the standard subdirectories. (define (variables-for-wrapping base-directories output-directory) - (define (collect-sub-dirs base-directories subdirectory selectors) + (define (collect-sub-dirs base-directories file-type subdirectory selectors) ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset ;; that exists and has at least one of the SELECTORS sub-directories, - ;; unless SELECTORS is the empty list. + ;; unless SELECTORS is the empty list. FILE-TYPE should by 'directory or + ;; 'regular file. For the later, it allows searching for plain files + ;; rather than directories. + (define exists? (match file-type + ('directory directory-exists?) + ('regular file-exists?))) + (filter-map (lambda (dir) (let ((directory (string-append dir subdirectory))) - (and (directory-exists? directory) + (and (exists? directory) (or (null? selectors) (any (lambda (selector) - (directory-exists? + (exists? (string-append directory selector))) selectors)) directory))) @@ -54,24 +61,34 @@ (define (collect-sub-dirs base-directories subdirectory selectors) (filter-map (match-lambda - ((variable type directory selectors ...) - (match (collect-sub-dirs base-directories directory selectors) + ((variable type file-type directory selectors ...) + (match (collect-sub-dirs base-directories file-type directory selectors) (() #f) (directories `(,variable ,type ,directories))))) ;; These shall match the search-path-specification for Qt and KDE ;; libraries. - (list '("XDG_DATA_DIRS" suffix "/share" - ;; These are "selectors": consider /share if and only if at least - ;; one of these sub-directories exist. This avoids adding - ;; irrelevant packages to XDG_DATA_DIRS just because they have a - ;; /share sub-directory. - "/applications" "/cursors" "/fonts" "/icons" "/glib-2.0/schemas" - "/mime" "/sounds" "/themes" "/wallpapers") - '("XDG_CONFIG_DIRS" suffix "/etc/xdg") - '("QT_PLUGIN_PATH" prefix "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" prefix "/lib/qt5/qml")))) + (list + ;; The XDG environment variables are defined with the 'suffix type, which + ;; allows the users to override or extend their value, so that custom icon + ;; themes can be honored, for example. + '("XDG_DATA_DIRS" suffix directory "/share" + ;; These are "selectors": consider /share if and only if at least + ;; one of these sub-directories exist. This avoids adding + ;; irrelevant packages to XDG_DATA_DIRS just because they have a + ;; /share sub-directory. + "/applications" "/cursors" "/fonts" "/icons" "/glib-2.0/schemas" + "/mime" "/sounds" "/themes" "/wallpapers") + '("XDG_CONFIG_DIRS" suffix directory "/etc/xdg") + ;; The following variables can be extended by the user, but not + ;; overridden, to ensure proper operation. + '("QT_PLUGIN_PATH" prefix directory "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" prefix directory "/lib/qt5/qml") + ;; QTWEBENGINEPROCESS_PATH accepts a single value, which makes 'exact the + ;; most suitable environment variable type for it. + '("QTWEBENGINEPROCESS_PATH" = regular + "/lib/qt5/libexec/QtWebEngineProcess")))) (define* (wrap-qt-program* program #:key inputs output-dir qt-wrap-excluded-inputs) @@ -90,7 +107,6 @@ (define input-directories (when (not (null? vars-to-wrap)) (apply wrap-program program vars-to-wrap)))) - (define* (wrap-qt-program program-name #:key inputs output (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)) "Wrap the specified programm (which must reside in the OUTPUT's \"/bin\" @@ -102,7 +118,6 @@ (define* (wrap-qt-program program-name #:key inputs output #:output-dir output #:inputs inputs #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs)) - (define* (wrap-all-qt-programs #:key inputs outputs (qt-wrap-excluded-outputs '()) (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs) @@ -133,5 +148,4 @@ (define handle-output #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs) (find-files-to-wrap output-dir)))))) - (for-each handle-output outputs) - #t) + (for-each handle-output outputs)) -- cgit v1.2.3 From f7e14782025bf87aaef694a21f34010b1a95f7f6 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 4 Jul 2021 04:26:01 +0200 Subject: cpio: Fix device number calculation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit “dev_t in glibc is a 64-bit quantity, with 32-bit major and minor numbers.” — glibc's The "tests/cpio.scm" was failing because (guix cpio) treated it as a 16-bit quantity instead, leading to header mismatches with the GNU cpio reference output. * guix/cpio.scm (device-number, device->major+minor): Use all the bits. --- guix/cpio.scm | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/cpio.scm b/guix/cpio.scm index c9932f5bf9..8038a11f3c 100644 --- a/guix/cpio.scm +++ b/guix/cpio.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2021 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -153,15 +154,20 @@ (define (mode->type mode) (else (error "unsupported file type" mode))))) -(define (device-number major minor) ;see +(define (device-number major minor) ; see glibc's "Return the device number for the device with MAJOR and MINOR, for use as the last argument of `mknod'." - (+ (* major 256) minor)) + (logior (ash (logand #x00000fff major) 8) + (ash (logand #xfffff000 major) 32) + (logand #x000000ff minor) + (ash (logand #xffffff00 minor) 12))) -(define (device->major+minor device) +(define (device->major+minor device) ; see glibc's "Return two values: the major and minor device numbers that make up DEVICE." - (values (ash device -8) - (logand device #xff))) + (values (logior (ash (logand #x00000000000fff00 device) -8) + (ash (logand #xfffff00000000000 device) -32)) + (logior (logand #x00000000000000ff device) + (ash (logand #x00000ffffff00000 device) -12)))) (define* (file->cpio-header file #:optional (file-name file) #:key (stat lstat)) -- cgit v1.2.3 From 77dba2281ffec5294f39d4f10f9cc64a936cf9ff Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 Jul 2021 18:02:11 +0200 Subject: ci: Represent build status as a symbol. * guix/ci.scm (define-enumeration-mapping): New macro. (integer->build-status): New procedure. ()[status]: Use it. --- guix/ci.scm | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ci.scm b/guix/ci.scm index 0af04ff97d..bf3573247a 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -75,13 +75,31 @@ (define-json-mapping make-build-product (file-size build-product-file-size) ;integer (path build-product-path)) ;string +(define-syntax-rule (define-enumeration-mapping proc + (names integers) ...) + (define (proc value) + (match value + (integers 'names) ...))) + +(define-enumeration-mapping integer->build-status + ;; Copied from 'build-status' in Cuirass. + (submitted -3) + (scheduled -2) + (started -1) + (succeeded 0) + (failed 1) + (failed-dependency 2) + (failed-other 3) + (canceled 4)) + (define-json-mapping make-build build? json->build (id build-id "id") ;integer (derivation build-derivation) ;string | #f (evaluation build-evaluation) ;integer (system build-system) ;string - (status build-status "buildstatus" ) ;integer + (status build-status "buildstatus" ;symbol + integer->build-status) (timestamp build-timestamp) ;integer (products build-products "buildproducts" ;* (lambda (products) -- cgit v1.2.3 From 073f198e34d8004a4ac4dba558683514e5562994 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 Jul 2021 19:35:18 +0200 Subject: ci: Add procedures to access jobs and builds. * guix/ci.scm (): New record type. (evaluation-jobs, build, job-build): New procedures. --- guix/ci.scm | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) (limited to 'guix') diff --git a/guix/ci.scm b/guix/ci.scm index bf3573247a..dde93bbd53 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -51,10 +51,18 @@ (define-module (guix ci) evaluation-complete? evaluation-checkouts + job? + job-build-id + job-status + job-name + %query-limit queued-builds latest-builds evaluation + evaluation-jobs + build + job-build latest-evaluations evaluations-for-commit @@ -109,6 +117,13 @@ (define-json-mapping make-build build? (vector->list products) '()))))) +(define-json-mapping make-job job? + json->job + (build-id job-build-id "build") ;integer + (status job-status "status" ;symbol + integer->build-status) + (name job-name)) ;string + (define-json-mapping make-checkout checkout? json->checkout (commit checkout-commit) ;string (SHA1) @@ -197,6 +212,28 @@ (define* (evaluations-for-commit url commit #:optional (limit %query-limit)) (evaluation-checkouts evaluation))) (latest-evaluations url limit))) +(define (evaluation-jobs url evaluation-id) + "Return the list of jobs of evaluation EVALUATION-ID." + (map json->job + (vector->list + (json->scm (http-fetch + (string-append url "/api/jobs?evaluation=" + (number->string evaluation-id))))))) + +(define (build url id) + "Look up build ID at URL and return it. Raise &http-get-error if it is not +found (404)." + (json->build + (http-fetch (string-append url "/build/" ;note: no "/api" here + (number->string id))))) + +(define (job-build url job) + "Return the build associated with JOB." + (build url (job-build-id job))) + +;; TODO: job history: +;; https://ci.guix.gnu.org/api/jobs/history?spec=master&names=coreutils.x86_64-linux&nr=10 + (define (find-latest-commit-with-substitutes url) "Return the latest commit with available substitutes for the Guix package definitions at URL. Return false if no commit were found." -- cgit v1.2.3 From b1e48b5b4e5db3c7b4223a4138e360a654767c0e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Jul 2021 22:59:45 +0200 Subject: status: Add missing newline after substitution completion message. * guix/status.scm (print-build-event): Add newline after "substitution of ~a complete" message. --- guix/status.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 1164c2a6e3..f351a56d92 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -558,7 +558,8 @@ (define erase-current-line* ;; If there are no jobs running, we already reported download completion ;; so there's nothing left to do. (unless (zero? (simultaneous-jobs status)) - (format port (success (G_ "substitution of ~a complete")) item)) + (format port (success (G_ "substitution of ~a complete")) item) + (newline port)) (when (and print-urls? (zero? (simultaneous-jobs status))) ;; Leave a blank line after the "downloading ..." line and the -- cgit v1.2.3 From b1a419ea3fdea2bff3f7f14da4b4e336334f408d Mon Sep 17 00:00:00 2001 From: Sarah Morgensen Date: Sun, 4 Jul 2021 15:00:15 -0700 Subject: import: go: Replace tildes with hyphens in package names. Fixes . * guix/import/go.scm (go-module->guix-package-name): Replace tildes with hyphens. Signed-off-by: Leo Prikler --- guix/import/go.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/go.scm b/guix/import/go.scm index 5e23d6a2b3..d8f838f635 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -430,9 +430,9 @@ (define (vcs-qualified-module-path->root-repo-url module-path) (define* (go-module->guix-package-name module-path #:optional version) "Converts a module's path to the canonical Guix format for Go packages. Optionally include a VERSION string to append to the name." - ;; Map dot, slash and underscore characters to hyphens. + ;; Map dot, slash, underscore and tilde characters to hyphens. (let ((module-path* (string-map (lambda (c) - (if (member c '(#\. #\/ #\_)) + (if (member c '(#\. #\/ #\_ #\~)) #\- c)) module-path))) -- cgit v1.2.3 From 45940f59aae10e257e10ed585c49a9383df62185 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Mon, 5 Jul 2021 16:06:22 +0200 Subject: guix: opam: Allow for whitespace at the start of an opam file. * guix/import/opam.scm (records): Accept whitespace at the beginning. --- guix/import/opam.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 0201376457..a35b01d277 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -66,7 +66,7 @@ (define-peg-pattern STRCHR body (range #\# #\頋))) (define-peg-pattern operator all (or "=" "!" "<" ">")) -(define-peg-pattern records body (* (and (or record weird-record) (* SP)))) +(define-peg-pattern records body (and (* SP) (* (and (or record weird-record) (* SP))))) (define-peg-pattern record all (and key COLON (* SP) value)) (define-peg-pattern weird-record all (and key (* SP) dict)) (define-peg-pattern key body (+ (or (range #\a #\z) "-"))) -- cgit v1.2.3 From 38bcef1c3b4f67abb314368d2248e08026219de3 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sat, 3 Jul 2021 23:08:15 -0400 Subject: guix: docker: Ensure repository name length limits are met. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/docker.scm (canonicalize-repository-name): Fix typo in doc. Capture repository name length limits and ensure they are met, by either truncating or padding the normalized name. Reported-by: Ludovic Courtès --- guix/docker.scm | 28 ++++++++++++++++++++++------ 1 file changed, 22 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/docker.scm b/guix/docker.scm index bd952e45ec..a6f73d423c 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès ;;; Copyright © 2018 Chris Marusich +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,8 +60,13 @@ (define (image-description id time) (container_config . #nil))) (define (canonicalize-repository-name name) - "\"Repository\" names are restricted to roughtl [a-z0-9_.-]. + "\"Repository\" names are restricted to roughly [a-z0-9_.-]. Return a version of TAG that follows these rules." + ;; Refer to https://docs.docker.com/docker-hub/repos/. + (define min-length 2) + (define padding-character #\a) + (define max-length 255) + (define ascii-letters (string->char-set "abcdefghijklmnopqrstuvwxyz")) @@ -70,11 +76,21 @@ (define separators (define repo-char-set (char-set-union char-set:digit ascii-letters separators)) - (string-map (lambda (chr) - (if (char-set-contains? repo-char-set chr) - chr - #\.)) - (string-trim (string-downcase name) separators))) + (define normalized-name + (string-map (lambda (chr) + (if (char-set-contains? repo-char-set chr) + chr + #\.)) + (string-trim (string-downcase name) separators))) + + (let ((l (string-length normalized-name))) + (match l + ((? (cut > <> max-length)) + (string-take normalized-name max-length)) + ((? (cut < <> min-length)) + (string-append normalized-name + (make-string (- min-length l) padding-character))) + (_ normalized-name)))) (define* (manifest path id #:optional (tag "guix")) "Generate a simple image manifest." -- cgit v1.2.3 From a8e4c158f9b7cc0adf010313b0f974e1a1aa63a7 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Thu, 1 Jul 2021 12:51:14 +0200 Subject: lint: Define some procedures for analysing code in phases. * guix/lint.scm (check-optional-tests): Extract logic for extracting the phases from a package to ... (find-phase-deltas): ... here, and ... (report-bogus-phase-deltas): ... here. (check-optional-tests)[check-check-procedure]: Extract code for extracting the procedure body to ... (find-procedure-body) ... here. (find-phase-procedure): New procedure. (report-bogus-phase-procedure): New procedure. Signed-off-by: Mathieu Othacehe --- guix/lint.scm | 117 +++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 84 insertions(+), 33 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 1f48bcc454..5125b7722c 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -161,6 +161,78 @@ (define-syntax make-warning ((_ package (G_ message) rest ...) (%make-warning package message rest ...)))) + +;;; +;;; Procedures for analysing Scheme code in package definitions +;;; + +(define* (find-procedure-body expression found + #:key (not-found (const '()))) + "Try to find the body of the procedure defined inline by EXPRESSION. +If it was found, call FOUND with its body. If it wasn't, call +the thunk NOT-FOUND." + (match expression + (`(,(or 'let 'let*) . ,_) + (find-procedure-body (car (last-pair expression)) found + #:not-found not-found)) + (`(,(or 'lambda 'lambda*) ,_ . ,code) + (found code)) + (_ (not-found)))) + +(define* (report-bogus-phase-deltas package bogus-deltas) + "Report a bogus invocation of ‘modify-phases’." + (list (make-warning package + ;; TRANSLATORS: 'modify-phases' is a Scheme syntax + ;; and should not be translated. + (G_ "incorrect call to ‘modify-phases’") + #:field 'arguments))) + +(define* (find-phase-deltas package found + #:key (not-found (const '())) + (bogus + (cut report-bogus-phase-deltas package <>))) + "Try to find the clauses of the ‘modify-phases’ form in the phases +specification of PACKAGE. If they were found, all FOUND with a list +of the clauses. If they weren't (e.g. because ‘modify-phases’ wasn't +used at all), call the thunk NOT-FOUND instead. If ‘modify-phases’ +was used, but the clauses don't form a list, call BOGUS with the +not-a-list." + (apply (lambda* (#:key phases #:allow-other-keys) + (define phases/sexp + (if (gexp? phases) + (gexp->approximate-sexp phases) + phases)) + (match phases/sexp + (`(modify-phases ,_ . ,changes) + ((if (list? changes) found bogus) changes)) + (_ (not-found)))) + (package-arguments package))) + +(define (report-bogus-phase-procedure package) + "Report a syntactically-invalid phase clause." + (list (make-warning package + ;; TRANSLATORS: See ‘modify-phases’ in the manual. + (G_ "invalid phase clause") + #:field 'arguments))) + +(define* (find-phase-procedure package expression found + #:key (not-found (const '())) + (bogus (cut report-bogus-phase-procedure + package))) + "Try to find the procedure in the phase clause EXPRESSION. If it was +found, call FOUND with the procedure expression. If EXPRESSION isn't +actually a phase clause, call the thunk BOGUS. If the phase form doesn't +have a procedure, call the thunk NOT-FOUND." + (match expression + (('add-after before after proc-expr) + (found proc-expr)) + (('add-before after before proc-expr) + (found proc-expr)) + (('replace _ proc-expr) + (found proc-expr)) + (('delete _) (not-found)) + (_ (bogus)))) + ;;; ;;; Checkers @@ -1111,46 +1183,25 @@ (define (sexp-contains-atom? sexp atom) (define (sexp-uses-tests?? sexp) "Test if SEXP contains the symbol 'tests?'." (sexp-contains-atom? sexp 'tests?)) + (define (check-procedure-body code) + (if (sexp-uses-tests?? code) + '() + (list (make-warning package + ;; TRANSLATORS: check and #:tests? are a + ;; Scheme symbol and keyword respectively + ;; and should not be translated. + (G_ "the 'check' phase should respect #:tests?") + #:field 'arguments)))) (define (check-check-procedure expression) - (match expression - (`(,(or 'let 'let*) . ,_) - (check-check-procedure (car (last-pair expression)))) - (`(,(or 'lambda 'lambda*) ,_ . ,code) - (if (sexp-uses-tests?? code) - '() - (list (make-warning package - ;; TRANSLATORS: check and #:tests? are a - ;; Scheme symbol and keyword respectively - ;; and should not be translated. - (G_ "the 'check' phase should respect #:tests?") - #:field 'arguments)))) - (_ '()))) + (find-procedure-body expression check-procedure-body)) (define (check-phases-delta delta) (match delta (`(replace 'check ,expression) (check-check-procedure expression)) (_ '()))) (define (check-phases-deltas deltas) - (match deltas - (() '()) - ((head . tail) - (append (check-phases-delta head) - (check-phases-deltas tail))) - (_ (list (make-warning package - ;; TRANSLATORS: modify-phases is a Scheme - ;; syntax and must not be translated. - (G_ "incorrect call to ‘modify-phases’") - #:field 'arguments))))) - (apply (lambda* (#:key phases #:allow-other-keys) - (define phases/sexp - (if (gexp? phases) - (gexp->approximate-sexp phases) - phases)) - (match phases/sexp - (`(modify-phases ,_ . ,changes) - (check-phases-deltas changes)) - (_ '()))) - (package-arguments package))) + (append-map check-phases-delta deltas)) + (find-phase-deltas package check-phases-deltas)) (define* (check-derivation package #:key store) "Emit a warning if we fail to compile PACKAGE to a derivation." -- cgit v1.2.3 From eac82c0e0a9f5afb5452928acf9b84cbc019c81c Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Thu, 1 Jul 2021 12:59:52 +0200 Subject: lint: Lint usages of 'wrap-program' without a "bash" input. When using 'wrap-program', "bash" (or "bash-minimal") should be in inputs. Otherwise, when cross-compiling, 'wrap-program' will use a native bash instead of the cross bash and the 'patch-shebangs' won't be able to correct this. Tobias Geerinckx-Rice is added to the copyright lines because a part of the "straw-viewer" package definition is included. This linter detects 365 problematic package definitions at time of writing. * guix/lint.scm (report-wrap-program-error): New procedure. (check-wrapper-inputs): New linter. (%local-checkers)[wrapper-inputs]: Add the new linter. ("explicit #:sh argument to 'wrap-program' is acceptable") ("'check-wrapper-inputs' detects 'wrap-program' without \"bash\" in inputs") ("'check-wrapper-inputs' detects 'wrap-qt-program' without \"bash\" in inputs") ("\"bash\" in 'inputs' satisfies 'check-wrapper-inputs'") ("\"bash-minimal\" in 'inputs' satisfies 'check-wrapper-inputs'") ("'cut' doesn't hide bad usages of 'wrap-program'") ("bogus phase specifications don't crash the linter"): New tests. Signed-off-by: Mathieu Othacehe --- guix/lint.scm | 48 ++++++++++++++++++++++++++++++++ tests/lint.scm | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 136 insertions(+) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 5125b7722c..8f31de041d 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -81,6 +81,7 @@ (define-module (guix lint) #:export (check-description-style check-inputs-should-be-native check-inputs-should-not-be-an-input-at-all + check-wrapper-inputs check-patch-file-names check-patch-headers check-synopsis-style @@ -491,6 +492,49 @@ (define (check-inputs-should-not-be-an-input-at-all package) (package-input-intersection (package-direct-inputs package) input-names)))) +(define (report-wrap-program-error package wrapper-name) + "Warn that \"bash-minimal\" is missing from 'inputs', while WRAPPER-NAME +requires it." + (make-warning package + (G_ "\"bash-minimal\" should be in 'inputs' when '~a' is used") + (list wrapper-name))) + +(define (check-wrapper-inputs package) + "Emit a warning if PACKAGE uses 'wrap-program' or similar, but \"bash\" +or \"bash-minimal\" is not in its inputs. 'wrap-script' is not supported." + (define input-names '("bash" "bash-minimal")) + (define has-bash-input? + (pair? (package-input-intersection (package-inputs package) + input-names))) + (define (check-procedure-body body) + (match body + ;; Explicitely setting an interpreter is acceptable, + ;; #:sh support is added on 'core-updates'. + ;; TODO(core-updates): remove mention of core-updates. + (('wrap-program _ '#:sh . _) '()) + (('wrap-program _ . _) + (list (report-wrap-program-error package 'wrap-program))) + ;; Wrapper of 'wrap-program' for Qt programs. + ;; TODO #:sh is not yet supported but probably will be. + (('wrap-qt-program _ '#:sh . _) '()) + (('wrap-qt-program _ . _) + (list (report-wrap-program-error package 'wrap-qt-program))) + ((x . y) + (append (check-procedure-body x) (check-procedure-body y))) + (_ '()))) + (define (check-phase-procedure expression) + (find-procedure-body expression check-procedure-body)) + (define (check-delta expression) + (find-phase-procedure package expression check-phase-procedure)) + (define (check-deltas deltas) + (append-map check-delta deltas)) + (if has-bash-input? + ;; "bash" (or "bash-minimal") is in 'inputs', so everything seems ok. + '() + ;; "bash" is not in 'inputs'. Verify 'wrap-program' and friends + ;; are unused + (find-phase-deltas package check-deltas))) + (define (package-name-regexp package) "Return a regexp that matches PACKAGE's name as a word at the beginning of a line." @@ -1696,6 +1740,10 @@ (define %local-checkers (name 'inputs-should-not-be-input) (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) + (lint-checker + (name 'wrapper-inputs) + (description "Make sure 'wrap-program' can finds its interpreter.") + (check check-wrapper-inputs)) (lint-checker (name 'license) ;; TRANSLATORS: is the name of a data type and must not be diff --git a/tests/lint.scm b/tests/lint.scm index 4ef400a9a0..82971db8f0 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Efraim Flashner ;;; Copyright © 2018, 2019 Arun Isaac ;;; Copyright © 2020 Timothy Sample +;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Maxime Devos ;;; @@ -47,6 +48,7 @@ (define-module (test-lint) #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) #:use-module (gnu packages python-xyz) + #:use-module ((gnu packages bash) #:select (bash bash-minimal)) #:use-module (web uri) #:use-module (web server) #:use-module (web server http) @@ -357,6 +359,92 @@ (define (warning-contains? str warnings) `(("python-setuptools" ,python-setuptools)))))) (check-inputs-should-not-be-an-input-at-all pkg)))) +(test-equal "explicit #:sh argument to 'wrap-program' is acceptable" + '() + (let* ((phases + ;; Loosely based on the "catfish" package + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda* (#:key inputs outputs #:allow-other-keys) + (define catfish (string-append (assoc-ref outputs "out") + "/bin/catfish")) + (define hsab (string-append (assoc-ref inputs "hsab") + "/bin/hsab")) + (wrap-program catfish #:sh hsab + `("PYTHONPATH" = (,"blabla"))))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (check-wrapper-inputs pkg))) + +(test-equal + "'check-wrapper-inputs' detects 'wrap-program' without \"bash\" in inputs" + "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used" + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda _ + (wrap-program the-binary bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + +(test-equal + "'check-wrapper-inputs' detects 'wrap-qt-program' without \"bash\" in inputs" + "\"bash-minimal\" should be in 'inputs' when 'wrap-qt-program' is used" + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'qtwrap + (lambda _ + (wrap-qt-program the-binary bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + +(test-equal "\"bash\" in 'inputs' satisfies 'check-wrapper-inputs'" + '() + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda _ + (wrap-program the-binary bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases)) + (inputs `(("bash" ,bash)))))) + (check-wrapper-inputs pkg))) + +(test-equal "\"bash-minimal\" in 'inputs' satisfies 'check-wrapper-inputs'" + '() + (let* ((phases + `(modify-phases %standard-phases + (add-after 'install 'wrap + (lambda _ + (wrap-program THE-BINARY bla-bla))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases)) + (inputs `(("bash-minimal" ,bash-minimal)))))) + (check-wrapper-inputs pkg))) + +(test-equal "'cut' doesn't hide bad usages of 'wrap-program'" + "\"bash-minimal\" should be in 'inputs' when 'wrap-program' is used" + (let* ((phases + ;; Taken from the "straw-viewer" package + `(modify-phases %standard-phases + (add-after 'install 'wrap-program + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin-dir (string-append out "/bin/")) + (site-dir (string-append out "/lib/perl5/site_perl/")) + (lib-path (getenv "PERL5LIB"))) + (for-each (cut wrap-program <> + `("PERL5LIB" ":" prefix + (,lib-path ,site-dir))) + (find-files bin-dir))))))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + +(test-equal "bogus phase specifications don't crash the linter" + "invalid phase clause" + (let* ((phases + `(modify-phases %standard-phases + (add-invalid))) + (pkg (dummy-package "x" (arguments `(#:phases ,phases))))) + (single-lint-warning-message (check-wrapper-inputs pkg)))) + (test-equal "file patches: different file name -> warning" "file names of patches should start with the package name" (single-lint-warning-message -- cgit v1.2.3 From 0dd136bc36709bd413505387ef44a5b60e6be74c Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Tue, 6 Jul 2021 09:02:50 +0200 Subject: Revert "syscalls: 'terminal-dimension' ignores EPERM." This reverts commit 17a102332a253f0e3b1f511fa7bda2094264a77c. See . --- guix/build/syscalls.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 8886fc0fb9..ac1b0c2eea 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -2236,8 +2236,8 @@ (define (terminal-dimension window-dimension port fall-back) ;; would return EINVAL instead in some cases: ;; . ;; Furthermore, some FUSE file systems like unionfs return ENOSYS for - ;; that ioctl, and bcachefs returns EPERM. - (if (memv errno (list ENOTTY EINVAL ENOSYS EPERM)) + ;; that ioctl. + (if (memv errno (list ENOTTY EINVAL ENOSYS)) (fall-back) (apply throw args)))))) -- cgit v1.2.3 From af2d6ec092c98ac5f32d8e9e182a141e1268805b Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 7 Jul 2021 14:40:51 -0400 Subject: self: Build translated manuals with a single process. Works around . * guix/self.scm (translate-texi-manuals): Set parallel-job-count to 1. --- guix/self.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 87d00ea64f..2cfdc41200 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -410,7 +410,10 @@ (define parallel-jobs ;; Limit thread creation by 'n-par-for-each'. Going beyond can ;; lead libgc 8.0.4 to abort with: ;; mmap(PROT_NONE) failed - (min (parallel-job-count) 4)) + ;; + ;; FIXME: The above error would still happen when using only 4 + ;; build jobs, so disable parallelism entirely for the time being. + (min (parallel-job-count) 1)) (mkdir #$output) (copy-recursively #$documentation "." -- cgit v1.2.3 From 609e66e45fb0de22cb0fd0a55c8a56eccc33299e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 Jul 2021 17:05:28 +0200 Subject: Revert "self: Build translated manuals with a single process." This reverts commit af2d6ec092c98ac5f32d8e9e182a141e1268805b, which the parent commit makes unnecessary. --- guix/self.scm | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 2cfdc41200..87d00ea64f 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -410,10 +410,7 @@ (define parallel-jobs ;; Limit thread creation by 'n-par-for-each'. Going beyond can ;; lead libgc 8.0.4 to abort with: ;; mmap(PROT_NONE) failed - ;; - ;; FIXME: The above error would still happen when using only 4 - ;; build jobs, so disable parallelism entirely for the time being. - (min (parallel-job-count) 1)) + (min (parallel-job-count) 4)) (mkdir #$output) (copy-recursively #$documentation "." -- cgit v1.2.3 From cf88c967afbf15c58efb0ba37d6638f1be9a0481 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 Jul 2021 17:32:05 +0200 Subject: self: Remove stale comment about "mmap(PROT_NONE) failed" crash. This crash was fixed by 0aef94e7bcbd272720f14c5343f74da5201ef90a, itself a followup to 47d48f0c43c13c0b43bc3e37b6239efd4bf2f74c. * guix/self.scm (translate-texi-manuals)[build]: Remove reference to the PROT_NONE bug. --- guix/self.scm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 87d00ea64f..530632db7d 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -407,9 +407,8 @@ (define (available-translations directory domain) "\\.[a-z]{2}(_[A-Z]{2})?\\.po$"))) (define parallel-jobs - ;; Limit thread creation by 'n-par-for-each'. Going beyond can - ;; lead libgc 8.0.4 to abort with: - ;; mmap(PROT_NONE) failed + ;; Limit thread creation by 'n-par-for-each', mostly to put an + ;; upper bound on memory usage. (min (parallel-job-count) 4)) (mkdir #$output) -- cgit v1.2.3 From edb328ad83bf55e021018719d24f7c29adc43a96 Mon Sep 17 00:00:00 2001 From: Brice Waegeneire Date: Sat, 19 Jun 2021 21:59:48 +0200 Subject: lint: Check for leading whitespace in description. * guix/lint.scm (check-description-style): Check for leading whitespace. * tests/lint.scm: ("description: leading whitespace"): New test. --- guix/lint.scm | 11 +++++++++++ tests/lint.scm | 7 +++++++ 2 files changed, 18 insertions(+) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 8f31de041d..ffd3f7007e 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -13,6 +13,7 @@ ;;; Copyright © 2020 Timothy Sample ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Maxime Devos +;;; Copyright © 2021 Brice Waegeneire ;;; ;;; This file is part of GNU Guix. ;;; @@ -376,6 +377,15 @@ (define (check-end-of-sentence-space description) infractions) #:field 'description))))) + (define (check-no-leading-whitespace description) + "Check that DESCRIPTION doesn't have trailing whitespace." + (if (string-prefix? " " description) + (list + (make-warning package + (G_ "description contains leading whitespace") + #:field 'description)) + '())) + (define (check-no-trailing-whitespace description) "Check that DESCRIPTION doesn't have trailing whitespace." (if (string-suffix? " " description) @@ -394,6 +404,7 @@ (define (check-no-trailing-whitespace description) ;; Use raw description for this because Texinfo rendering ;; automatically fixes end of sentence space. (check-end-of-sentence-space description) + (check-no-leading-whitespace description) (check-no-trailing-whitespace description) (match (check-texinfo-markup description) ((and warning (? lint-warning?)) (list warning)) diff --git a/tests/lint.scm b/tests/lint.scm index 82971db8f0..0f51b9ef79 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -163,6 +163,13 @@ (define (warning-contains? str warnings) (description "This is a 'quoted' thing.")))) (check-description-style pkg)))) +(test-equal "description: leading whitespace" + "description contains leading whitespace" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (description " Whitespace.")))) + (check-description-style pkg)))) + (test-equal "description: trailing whitespace" "description contains trailing whitespace" (single-lint-warning-message -- cgit v1.2.3 From b73b9aae0d986b59f9b235788cfb758bf6b5411d Mon Sep 17 00:00:00 2001 From: Steve Sprang Date: Tue, 9 Jan 2018 14:00:11 -0800 Subject: utils: Add a procedure for pretty printing tabular data. * guix/utils.scm (pretty-print-table): New procedure. Co-authored-by: Maxim Cournoyer Signed-off-by: Maxim Cournoyer --- guix/utils.scm | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 05af86fc37..2c56c8b2e0 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -10,6 +10,8 @@ ;;; Copyright © 2020 Efraim Flashner ;;; Copyright © 2021 Simon Tournier ;;; Copyright © 2021 Chris Marusich +;;; Copyright © 2018 Steve Sprang +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -123,7 +125,9 @@ (define-module (guix utils) canonical-newline-port string-distance - string-closest)) + string-closest + + pretty-print-table)) ;;; @@ -935,6 +939,33 @@ (define* (string-closest trial tests #:key (threshold 3)) #f +inf.0 tests))) + +;;; +;;; Prettified output. +;;; + +(define* (pretty-print-table rows #:key (max-column-width 20)) + "Print ROWS in neat columns. All rows should be lists of strings and each +row should have the same length. The columns are separated by a tab +character, and aligned using spaces. The maximum width of each column is +bound by MAX-COLUMN-WIDTH." + (let* ((number-of-columns-to-pad (if (null? rows) + 0 + (1- (length (first rows))))) + ;; Ignore the last column as it is left aligned and doesn't need + ;; padding; this prevents printing extraneous trailing spaces. + (column-widths (fold (lambda (row maximums) + (map max (map string-length row) maximums)) + ;; Initial max width is 0 for each column. + (make-list number-of-columns-to-pad 0) + (map (cut drop-right <> 1) rows))) + (column-formats (map (cut format #f "~~~da" <>) + (map (cut min <> max-column-width) + column-widths))) + (fmt (string-append (string-join column-formats "\t") "\t~a"))) + (setvbuf (current-output-port) 'block) ;for better performance + (for-each (cut format #t "~?~%" fmt <>) rows))) + ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: -- cgit v1.2.3 From 481d66052762c292798e123482e5b8f7358d1876 Mon Sep 17 00:00:00 2001 From: Steve Sprang Date: Tue, 9 Jan 2018 14:10:04 -0800 Subject: package: Improve output appearance when listing packages. * guix/scripts/package.scm (process-query): Use pretty-print-table when listing installed and available packages. Modified-by: Maxim Cournoyer Signed-off-by: Maxim Cournoyer --- guix/scripts/package.scm | 37 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 694959d326..a34ecdcb54 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2019 Tobias Geerinckx-Rice ;;; Copyright © 2020 Ricardo Wurmus ;;; Copyright © 2020 Simon Tournier +;;; Copyright © 2018 Steve Sprang ;;; ;;; This file is part of GNU Guix. ;;; @@ -831,15 +832,14 @@ (define (diff-profiles profile numbers) (map profile-manifest profiles))) (installed (manifest-entries manifest))) (leave-on-EPIPE - (for-each (match-lambda - (($ name version output path _) - (when (or (not regexp) - (regexp-exec regexp name)) - (format #t "~a\t~a\t~a\t~a~%" - name (or version "?") output path)))) - - ;; Show most recently installed packages last. - (reverse installed)))) + (let ((rows (filter-map + (match-lambda + (($ name version output path _) + (and (regexp-exec regexp name) + (list name (or version "?") output path)))) + installed))) + ;; Show most recently installed packages last. + (pretty-print-table (reverse rows))))) #t) (('list-available regexp) @@ -862,16 +862,15 @@ (define (diff-profiles profile numbers) result)) '()))) (leave-on-EPIPE - (for-each (match-lambda - ((name version outputs location) - (format #t "~a\t~a\t~a\t~a~%" - name version - (string-join outputs ",") - (location->string location)))) - (sort available - (match-lambda* - (((name1 . _) (name2 . _)) - (stringstring location)))) + (sort available + (match-lambda* + (((name1 . _) (name2 . _)) + (string Date: Tue, 9 Jan 2018 14:20:12 -0800 Subject: ui: Improve output appearance when listing generations. * guix/ui.scm (display-profile-content-diff): Use pretty-print-table to format output. (display-profile-content): Likewise. Signed-off-by: Maxim Cournoyer --- guix/ui.scm | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 26a437e904..1428c254b3 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -16,6 +16,7 @@ ;;; Copyright © 2019, 2021 Simon Tournier ;;; Copyright © 2020 Arun Isaac ;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2018 Steve Sprang ;;; ;;; This file is part of GNU Guix. ;;; @@ -1889,10 +1890,10 @@ (define (display-profile-content-diff profile gen1 gen2) (define (equal-entry? first second) (string= (manifest-entry-item first) (manifest-entry-item second))) - (define (display-entry entry prefix) + (define (make-row entry prefix) (match entry (($ name version output location _) - (format #t " ~a ~a\t~a\t~a\t~a~%" prefix name version output location)))) + (list (format #f " ~a ~a" prefix name) version output location)))) (define (list-entries number) (manifest-entries (profile-manifest (generation-file-name profile number)))) @@ -1903,8 +1904,8 @@ (define (display-diff profile old new) equal-entry? (list-entries new) (list-entries old))) (removed (lset-difference equal-entry? (list-entries old) (list-entries new)))) - (for-each (cut display-entry <> "+") added) - (for-each (cut display-entry <> "-") removed) + (pretty-print-table (append (map (cut make-row <> "+") added) + (map (cut make-row <> "-") removed))) (newline))) (display-diff profile gen1 gen2)) @@ -1932,15 +1933,17 @@ (define-syntax-rule (with-profile-lock profile exp ...) (define (display-profile-content profile number) "Display the packages in PROFILE, generation NUMBER, in a human-readable way." - (for-each (match-lambda - (($ name version output location _) - (format #t " ~a\t~a\t~a\t~a~%" - name version output location))) - - ;; Show most recently installed packages last. - (reverse - (manifest-entries - (profile-manifest (generation-file-name profile number)))))) + + (define entry->row + (match-lambda + (($ name version output location _) + (list (string-append " " name) version output location)))) + + (let* ((manifest (profile-manifest (generation-file-name profile number))) + (entries (manifest-entries manifest)) + (rows (map entry->row entries))) + ;; Show most recently installed packages last. + (pretty-print-table (reverse rows)))) (define (display-generation-change previous current) (format #t (G_ "switched from generation ~a to ~a~%") previous current)) -- cgit v1.2.3 From f3b20baa4d1375d053bcadd9b804f52556142656 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Wed, 7 Jul 2021 22:58:45 +0200 Subject: substitute: Fix handling of short option "-h". The short option was listed in the help-text, but not recognized. --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 03115ffe44..c044e1d47a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -777,7 +777,7 @@ (define reply-port (loop)))))) ((or ("-V") ("--version")) (show-version-and-exit "guix substitute")) - (("--help") + ((or ("-h") ("--help")) (show-help)) (opts (leave (G_ "~a: unrecognized options~%") opts)))))) -- cgit v1.2.3 From ccdf7b8006bd5173cd8ff7d2fe732fc171d38f5d Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Thu, 8 Jul 2021 00:45:41 +0200 Subject: substitutes: Properly construct URLs. Use relative URIs and "resolve-uri-reference" (which implements the algorithm specified in RFC 3986 section 5.2.2) for building the URL, instead of just appending strings. This avoids issued if the cache-url ends with a slash. * guix/substitutes.scm (narinfo-request): Use resolve-uri-reference for constructing the url. --- guix/substitutes.scm | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/substitutes.scm b/guix/substitutes.scm index 4987cda165..a5c554acff 100644 --- a/guix/substitutes.scm +++ b/guix/substitutes.scm @@ -37,7 +37,8 @@ (define-module (guix substitutes) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select ((open-connection-for-uri - . guix:open-connection-for-uri))) + . guix:open-connection-for-uri) + resolve-uri-reference)) #:use-module (guix progress) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) @@ -155,10 +156,12 @@ (define host (define (narinfo-request cache-url path) "Return an HTTP request for the narinfo of PATH at CACHE-URL." - (let ((url (string-append cache-url "/" (store-path-hash-part path) - ".narinfo")) - (headers '((User-Agent . "GNU Guile")))) - (build-request (string->uri url) #:method 'GET #:headers headers))) + (let* ((base (string->uri cache-url)) + (ref (build-relative-ref + #:path (string-append (store-path-hash-part path) ".narinfo"))) + (url (resolve-uri-reference ref base)) + (headers '((User-Agent . "GNU Guile")))) + (build-request url #:method 'GET #:headers headers))) (define (narinfo-from-file file url) "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f -- cgit v1.2.3 From 3ee0f170c8bd883728d8abb2c2e00f445c13f17d Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Thu, 8 Jul 2021 00:52:22 +0200 Subject: ci: Properly construct URLs. Implement a new function "api-url", which constructs URLs using relative URI and "resolve-uri-reference" (which implements the algorithm specified in RFC 3986 section 5.2.2) for building the URL, instead of just appending strings. This avoids issued if the server-url ends with a slash. Since "api-url" uses URI-objects, it makes sense to also construct the query-part of the URL here. For this "api-url" accepts optional key-value-pairs. New function "json-api-fetch" is a wrapper using "api-url". * guix/ci.scm (api-url): New function. (build): Use it. (json-api-fetch): New function. (queued-builds, latest-builds, evaluation, latest-evaluations, evaluation-jobs: Use it. --- guix/ci.scm | 82 ++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 49 insertions(+), 33 deletions(-) (limited to 'guix') diff --git a/guix/ci.scm b/guix/ci.scm index dde93bbd53..6a3af8b42c 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -20,9 +20,12 @@ (define-module (guix ci) #:use-module (guix http-client) #:use-module (guix utils) + #:use-module ((guix build download) + #:select (resolve-uri-reference)) #:use-module (json) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (web uri) #:use-module (guix i18n) #:use-module (guix diagnostics) #:autoload (guix channels) (channel) @@ -146,16 +149,44 @@ (define %query-limit ;; Max number of builds requested in queries. 1000) +(define* (api-url base-url path #:rest query) + "Build a proper API url, taking into account BASE-URL's trailing slashes. +QUERY takes any number of '(\"name\" value) 2-element lists, with VALUE being +either a string or a number (which will be converted to a string). If VALUE +is #f, the respective element will not be added to the query parameters. +Other types of VALUE will raise an error since this low-level function is +api-agnostic." + + (define (build-query-string query) + (let lp ((query (or (reverse query) '())) (acc '())) + (match query + (() (string-concatenate acc)) + (((_ #f) . rest) (lp rest acc)) + (((name val) . rest) + (lp rest (cons* + name "=" + (if (string? val) (uri-encode val) (number->string val)) + (if (null? acc) "" "&") + acc)))))) + + (let* ((query-string (build-query-string query)) + (base (string->uri base-url)) + (ref (build-relative-ref #:path path #:query query-string))) + (resolve-uri-reference ref base))) + (define (json-fetch url) (let* ((port (http-fetch url)) (json (json->scm port))) (close-port port) json)) +(define* (json-api-fetch base-url path #:rest query) + (json-fetch (apply api-url base-url path query))) + (define* (queued-builds url #:optional (limit %query-limit)) "Return the list of queued derivations on URL." - (let ((queue (json-fetch (string-append url "/api/queue?nr=" - (number->string limit))))) + (let ((queue + (json-api-fetch url "/api/queue" `("nr" ,limit)))) (map json->build (vector->list queue)))) (define* (latest-builds url #:optional (limit %query-limit) @@ -163,28 +194,21 @@ (define* (latest-builds url #:optional (limit %query-limit) "Return the latest builds performed by the CI server at URL. If EVALUATION is an integer, restrict to builds of EVALUATION. If SYSTEM is true (a system string such as \"x86_64-linux\"), restrict to builds for SYSTEM." - (define* (option name value #:optional (->string identity)) - (if value - (string-append "&" name "=" (->string value)) - "")) - - (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr=" - (number->string limit) - (option "evaluation" evaluation - number->string) - (option "system" system) - (option "job" job) - (option "status" status - number->string))))) + (let ((latest (json-api-fetch + url "/api/latestbuilds" + `("nr" ,limit) + `("evaluation" ,evaluation) + `("system" ,system) + `("job" ,job) + `("status" ,status)))) ;; Note: Hydra does not provide a "derivation" field for entries in ;; 'latestbuilds', but Cuirass does. (map json->build (vector->list latest)))) (define (evaluation url evaluation) "Return the given EVALUATION performed by the CI server at URL." - (let ((evaluation (json-fetch - (string-append url "/api/evaluation?id=" - (number->string evaluation))))) + (let ((evaluation + (json-api-fetch url "/api/evaluation" `("id" ,evaluation)))) (json->evaluation evaluation))) (define* (latest-evaluations url @@ -192,16 +216,10 @@ (define* (latest-evaluations url #:key spec) "Return the latest evaluations performed by the CI server at URL. If SPEC is passed, only consider the evaluations for the given SPEC specification." - (let ((spec (if spec - (format #f "&spec=~a" spec) - ""))) - (map json->evaluation - (vector->list - (json->scm - (http-fetch - (string-append url "/api/evaluations?nr=" - (number->string limit) - spec))))))) + (map json->evaluation + (vector->list + (json-api-fetch + url "/api/evaluations" `("nr" ,limit) `("spec" ,spec))))) (define* (evaluations-for-commit url commit #:optional (limit %query-limit)) "Return the evaluations among the latest LIMIT evaluations that have COMMIT @@ -216,16 +234,14 @@ (define (evaluation-jobs url evaluation-id) "Return the list of jobs of evaluation EVALUATION-ID." (map json->job (vector->list - (json->scm (http-fetch - (string-append url "/api/jobs?evaluation=" - (number->string evaluation-id))))))) + (json-api-fetch url "/api/jobs" `("evaluation" ,evaluation-id))))) (define (build url id) "Look up build ID at URL and return it. Raise &http-get-error if it is not found (404)." (json->build - (http-fetch (string-append url "/build/" ;note: no "/api" here - (number->string id))))) + (http-fetch (api-url url (string-append "/build/" ;note: no "/api" here + (number->string id)))))) (define (job-build url job) "Return the build associated with JOB." -- cgit v1.2.3 From 59d20bcfcc92e51fb451001ed52b21f6daf8013c Mon Sep 17 00:00:00 2001 From: Sarah Morgensen via Guix-patches via Date: Thu, 15 Jul 2021 18:41:49 -0700 Subject: import: go: Fix parsing of pkg.go.dev licenses after site update. * guix/import/go.scm (go-package-licenses): Find license names in 'h2 // div // *text*' elements rather than 'h2 // *text*' elements. Signed-off-by: Maxim Cournoyer --- guix/import/go.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/go.scm b/guix/import/go.scm index d8f838f635..f6a68d62bb 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -146,7 +146,7 @@ (define (go-package-licenses name) ;; 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*)))) + h2 // div // *text*)))) (select (html->sxml body #:strict? #t)))) (define (sxml->texi sxml-node) -- cgit v1.2.3 From 5eba9c0960afdc352180f739ca3ba56f680c514b Mon Sep 17 00:00:00 2001 From: Sarah Morgensen via Guix-patches via Date: Thu, 15 Jul 2021 19:01:52 -0700 Subject: import: go: Handle multiple go-import meta tags. * guix/import/go.scm (fetch-module-meta-data): Parse all go-import meta tags and return the first 'module-meta' with a matching import prefix. [go-import->module-meta]: Extract parsing into new procedure. Signed-off-by: Maxim Cournoyer --- guix/import/go.scm | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/import/go.scm b/guix/import/go.scm index f6a68d62bb..24d12acd97 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -460,17 +460,21 @@ (define (fetch-module-meta-data module-path) "Retrieve the module meta-data from its landing page. This is necessary because goproxy servers don't currently provide all the information needed to build a package." + (define (go-import->module-meta content-text) + (match (string-split content-text #\space) + ((root-path vcs repo-url) + (make-module-meta root-path (string->symbol vcs) + (strip-.git-suffix/maybe repo-url))))) ;; (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 (html->sxml meta-data #:strict? #t)) (() #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) - (strip-.git-suffix/maybe repo-url)))))))) + ((('content content-text) ..1) + (find (lambda (meta) + (string-prefix? (module-meta-import-prefix meta) module-path)) + (map go-import->module-meta content-text)))))) (define (module-meta-data-repo-url meta-data goproxy) "Return the URL where the fetcher which will be used can download the -- cgit v1.2.3 From 793ba333c6039545684e8af7e384704e76bc0f2f Mon Sep 17 00:00:00 2001 From: Sarah Morgensen Date: Fri, 16 Jul 2021 21:01:28 -0700 Subject: import: go: Upgrade go.mod parser. Upgrade the go.mod parser to handle the full go.mod spec, and to gracefully handle unexpected/malformed syntax. Restructure parser usage, making the parse tree available for other uses. guix/import/go.scm (parse-go.mod): Parse using (ice-9 peg) instead of regex matching for more robustness. Return a list of directives. (go.mod-directives): New procedure. (go.mod-requirements): Likewise. (go-module->guix-package): Use it. (%go.mod-replace-directive-rx): Remove unused variable. tests/go.scm (testing-parse-mod): Adjust accordingly. (go.mod-requirements) (fixture-go-mod-unparseable) (fixture-go-mod-retract) (fixture-go-mod-strings): New variables. ("parse-go.mod: simple") ("parse-go.mod: comments and unparseable lines") ("parse-go.mod: retract") ("parse-go.mod: raw strings and quoted strings") ("parse-go.mod: complete"): New tests. Signed-off-by: Maxim Cournoyer --- guix/import/go.scm | 249 ++++++++++++++++++++++++++++------------------------- tests/go.scm | 133 +++++++++++++++++++++++++++- 2 files changed, 262 insertions(+), 120 deletions(-) (limited to 'guix') diff --git a/guix/import/go.scm b/guix/import/go.scm index 24d12acd97..a6e2af215f 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Ludovic Courtès ;;; Copyright © 2021 Xinglu Chen -;; Copyright © 2021 Sarah Morgensen +;;; Copyright © 2021 Sarah Morgensen ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,6 +41,7 @@ (define-module (guix import go) #:autoload (guix base32) (bytevector->nix-base32-string) #:autoload (guix build utils) (mkdir-p) #:use-module (ice-9 match) + #:use-module (ice-9 peg) #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) @@ -244,129 +245,139 @@ (define (fetch-go.mod goproxy module-path version) (go-path-escape version)))) (http-fetch* url))) -(define %go.mod-require-directive-rx - ;; A line in a require directive is composed of a module path and - ;; a version separated by whitespace and an optionnal '//' comment at - ;; the end. - (make-regexp - (string-append - "^[[: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:]]+)" ;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." - ;; 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 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 - (values requirements replaced)) - ((string=? line "require (") - ;; a require block begins, delegate parsing to IN-REQUIRE - (in-require requirements replaced)) - ((string=? line "replace (") - ;; a replace block begins, delegate parsing to IN-REPLACE - (in-replace requirements replaced)) - ((string-prefix? "require " line) - ;; 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 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 requirements replaced))))) - - (define (in-require requirements replaced) - (let ((line (read-line))) - (cond - ((eof-object? line) - ;; this should never happen here but we ignore silently - (values requirements replaced)) - ((string=? line ")") - ;; end of block, coming back to toplevel - (toplevel requirements replaced)) - (#t - (call-with-values (lambda () - (require-directive requirements replaced line)) - in-require))))) - - (define (in-replace requirements replaced) - (let ((line (read-line))) - (cond - ((eof-object? line) - ;; this should never happen here but we ignore silently - (values requirements replaced)) - ((string=? line ")") - ;; end of block, coming back to toplevel - (toplevel requirements replaced)) - (#t - (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)) - ;; 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))) - (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))))) + "Parse the go.mod file CONTENT, returning a list of directives, comments, +and unknown lines. Each sublist begins with a symbol (go, module, require, +replace, exclude, retract, comment, or unknown) and is followed by one or more +sublists. Each sublist begins with a symbol (module-path, version, file-path, +comment, or unknown) and is followed by the indicated data." + ;; https://golang.org/ref/mod#go-mod-file-grammar + (define-peg-pattern NL none "\n") + (define-peg-pattern WS none (or " " "\t" "\r")) + (define-peg-pattern => none (and (* WS) "=>")) + (define-peg-pattern punctuation none (or "," "=>" "[" "]" "(" ")")) + (define-peg-pattern comment all + (and (ignore "//") (* WS) (* (and (not-followed-by NL) peg-any)))) + (define-peg-pattern EOL body (and (* WS) (? comment) NL)) + (define-peg-pattern block-start none (and (* WS) "(" EOL)) + (define-peg-pattern block-end none (and (* WS) ")" EOL)) + (define-peg-pattern any-line body + (and (* WS) (* (and (not-followed-by NL) peg-any)) EOL)) + + ;; Strings and identifiers + (define-peg-pattern identifier body + (+ (and (not-followed-by (or NL WS punctuation)) peg-any))) + (define-peg-pattern string-raw body + (and (ignore "`") (+ (and (not-followed-by "`") peg-any)) (ignore "`"))) + (define-peg-pattern string-quoted body + (and (ignore "\"") + (+ (or (and (ignore "\\") peg-any) + (and (not-followed-by "\"") peg-any))) + (ignore "\""))) + (define-peg-pattern string-or-ident body + (and (* WS) (or string-raw string-quoted identifier))) + + (define-peg-pattern version all string-or-ident) + (define-peg-pattern module-path all string-or-ident) + (define-peg-pattern file-path all string-or-ident) + + ;; Non-directive lines + (define-peg-pattern unknown all any-line) + (define-peg-pattern block-line body + (or EOL (and (not-followed-by block-end) unknown))) + + ;; GoDirective = "go" GoVersion newline . + (define-peg-pattern go all (and (ignore "go") version EOL)) + + ;; ModuleDirective = "module" ( ModulePath | "(" newline ModulePath newline ")" ) newline . + (define-peg-pattern module all + (and (ignore "module") (or (and block-start module-path EOL block-end) + (and module-path EOL)))) + + ;; The following directives may all be used solo or in a block + ;; RequireSpec = ModulePath Version newline . + (define-peg-pattern require all (and module-path version EOL)) + (define-peg-pattern require-top body + (and (ignore "require") + (or (and block-start (* (or require block-line)) block-end) require))) + + ;; ExcludeSpec = ModulePath Version newline . + (define-peg-pattern exclude all (and module-path version EOL)) + (define-peg-pattern exclude-top body + (and (ignore "exclude") + (or (and block-start (* (or exclude block-line)) block-end) exclude))) + + ;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline + ;; | ModulePath [ Version ] "=>" ModulePath Version newline . + (define-peg-pattern original all (or (and module-path version) module-path)) + (define-peg-pattern with all (or (and module-path version) file-path)) + (define-peg-pattern replace all (and original => with EOL)) + (define-peg-pattern replace-top body + (and (ignore "replace") + (or (and block-start (* (or replace block-line)) block-end) replace))) + + ;; RetractSpec = ( Version | "[" Version "," Version "]" ) newline . + (define-peg-pattern range all + (and (* WS) (ignore "[") version + (* WS) (ignore ",") version (* WS) (ignore "]"))) + (define-peg-pattern retract all (and (or range version) EOL)) + (define-peg-pattern retract-top body + (and (ignore "retract") + (or (and block-start (* (or retract block-line)) block-end) retract))) + + (define-peg-pattern go-mod body + (* (and (* WS) (or go module require-top exclude-top replace-top + retract-top EOL unknown)))) + + (let ((tree (peg:tree (match-pattern go-mod content))) + (keywords '(go module require replace exclude retract comment unknown))) + (keyword-flatten keywords tree))) ;; Prevent inlining of this procedure, which is accessed by unit tests. (set! parse-go.mod parse-go.mod) +(define (go.mod-directives go.mod directive) + "Return the list of top-level directive bodies in GO.MOD matching the symbol +DIRECTIVE." + (filter-map (match-lambda + (((? (cut eq? <> directive) head) . rest) rest) + (_ #f)) + go.mod)) + +(define (go.mod-requirements go.mod) + "Compute and return the list of requirements specified by GO.MOD." + (define (replace directive requirements) + (define (maybe-replace module-path new-requirement) + ;; Do not allow version updates for indirect dependencies (see: + ;; https://golang.org/ref/mod#go-mod-file-replace). + (if (and (equal? module-path (first new-requirement)) + (not (assoc-ref requirements module-path))) + requirements + (cons new-requirement (alist-delete module-path requirements)))) + + (match directive + ((('original ('module-path module-path) . _) with . _) + (match with + (('with ('file-path _) . _) + (alist-delete module-path requirements)) + (('with ('module-path new-module-path) ('version new-version) . _) + (maybe-replace module-path + (list new-module-path new-version))))))) + + (define (require directive requirements) + (match directive + ((('module-path module-path) ('version version) . _) + (cons (list module-path version) requirements)))) + + (let* ((requires (go.mod-directives go.mod 'require)) + (replaces (go.mod-directives go.mod 'replace)) + (requirements (fold require '() requires))) + (fold replace requirements replaces))) + +;; Prevent inlining of this procedure, which is accessed by unit tests. +(set! go.mod-requirements go.mod-requirements) + (define-record-type (%make-vcs url-prefix root-regex type) vcs? @@ -592,7 +603,7 @@ (define* (go-module->guix-package module-path #:key 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+versions (go.mod-requirements (parse-go.mod content))) (dependencies (if pin-versions? dependencies+versions (map car dependencies+versions))) diff --git a/tests/go.scm b/tests/go.scm index 2dfdc97eb5..6749f4585f 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright 2021 Franois Joulaud +;;; Copyright 2021 Sarah Morgensen ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,6 +32,9 @@ (define-module (tests-import-go) #:use-module (srfi srfi-64) #:use-module (web response)) +(define go.mod-requirements + (@@ (guix import go) go.mod-requirements)) + (define parse-go.mod (@@ (guix import go) parse-go.mod)) @@ -95,6 +99,41 @@ (define fixture-go-mod-complete ") +(define fixture-go-mod-unparseable + "module my/thing +go 1.12 // avoid feature X +require other/thing v1.0.2 +// Security issue: CVE-XXXXX +exclude old/thing v1.2.3 +new-directive another/thing yet-another/thing +replace ( + bad/thing v1.4.5 => good/thing v1.4.5 + // Unparseable + bad/thing [v1.4.5, v1.9.7] => good/thing v2.0.0 +) +") + +(define fixture-go-mod-retract + "retract v0.9.1 + +retract ( + v1.9.2 + [v1.0.0, v1.7.9] +) +") + +(define fixture-go-mod-strings + "require `example.com/\"some-repo\"` v1.9.3 +require ( + `example.com/\"another.repo\"` v1.0.0 + \"example.com/special!repo\" v9.3.1 +) +replace \"example.com/\\\"some-repo\\\"\" => `launchpad.net/some-repo` v1.9.3 +replace ( + \"example.com/\\\"another.repo\\\"\" => launchpad.net/another-repo v1.0.0 +) +") + (define fixtures-go-check-test (let ((version "{\"Version\":\"v0.0.0-20201130134442-10cb98267c6c\",\"Time\":\"2020-11-30T13:44:42Z\"}") @@ -178,7 +217,7 @@ (define (inf? p1 p2) (string good/thing v2.0.0")) + (parse-go.mod fixture-go-mod-unparseable)) + +(test-equal "parse-go.mod: retract" + `((retract (version "v0.9.1")) + (retract (version "v1.9.2")) + (retract (range (version "v1.0.0") (version "v1.7.9")))) + (parse-go.mod fixture-go-mod-retract)) + +(test-equal "parse-go.mod: raw strings and quoted strings" + `((require (module-path "example.com/\"some-repo\"") (version "v1.9.3")) + (require (module-path "example.com/\"another.repo\"") (version "v1.0.0")) + (require (module-path "example.com/special!repo") (version "v9.3.1")) + (replace (original (module-path "example.com/\"some-repo\"")) + (with (module-path "launchpad.net/some-repo") (version "v1.9.3"))) + (replace (original (module-path "example.com/\"another.repo\"")) + (with (module-path "launchpad.net/another-repo") (version "v1.0.0")))) + (parse-go.mod fixture-go-mod-strings)) + +(test-equal "parse-go.mod: complete" + `((module (module-path "M")) + (go (version "1.13")) + (replace (original (module-path "github.com/myname/myproject/myapi")) + (with (file-path "./api"))) + (replace (original (module-path "github.com/mymname/myproject/thissdk")) + (with (file-path "../sdk"))) + (replace (original (module-path "launchpad.net/gocheck")) + (with (module-path "github.com/go-check/check") + (version "v0.0.0-20140225173054-eb6ee6f84d0a"))) + (require (module-path "github.com/user/project") + (version "v1.1.11")) + (require (module-path "github.com/user/project/sub/directory") + (version "v1.1.12")) + (require (module-path "bitbucket.org/user/project") + (version "v1.11.20")) + (require (module-path "bitbucket.org/user/project/sub/directory") + (version "v1.11.21")) + (require (module-path "launchpad.net/project") + (version "v1.1.13")) + (require (module-path "launchpad.net/project/series") + (version "v1.1.14")) + (require (module-path "launchpad.net/project/series/sub/directory") + (version "v1.1.15")) + (require (module-path "launchpad.net/~user/project/branch") + (version "v1.1.16")) + (require (module-path "launchpad.net/~user/project/branch/sub/directory") + (version "v1.1.17")) + (require (module-path "hub.jazz.net/git/user/project") + (version "v1.1.18")) + (require (module-path "hub.jazz.net/git/user/project/sub/directory") + (version "v1.1.19")) + (require (module-path "k8s.io/kubernetes/subproject") + (version "v1.1.101")) + (require (module-path "one.example.com/abitrary/repo") + (version "v1.1.111")) + (require (module-path "two.example.com/abitrary/repo") + (version "v0.0.2")) + (require (module-path "quoted.example.com/abitrary/repo") + (version "v0.0.2")) + (replace (original (module-path "two.example.com/abitrary/repo")) + (with (module-path "github.com/corp/arbitrary-repo") + (version "v0.0.2"))) + (replace (original (module-path "golang.org/x/sys")) + (with (module-path "golang.org/x/sys") + (version "v0.0.0-20190813064441-fde4db37ae7a")) + (comment "pinned to release-branch.go1.13")) + (replace (original (module-path "golang.org/x/tools")) + (with (module-path "golang.org/x/tools") + (version "v0.0.0-20190821162956-65e3620a7ae7")) + (comment "pinned to release-branch.go1.13"))) + (parse-go.mod fixture-go-mod-complete)) + ;;; End-to-end tests for (guix import go) (define (mock-http-fetch testcase) (lambda (url . rest) -- cgit v1.2.3 From 15b4372b6019fa515c5ef01bd290145a8d507000 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sun, 18 Jul 2021 01:46:29 -0400 Subject: import: go: Fix indentation. * guix/import/go.scm: Fix indentation. --- guix/import/go.scm | 58 +++++++++++++++++++++++++++--------------------------- 1 file changed, 29 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/guix/import/go.scm b/guix/import/go.scm index a6e2af215f..617a0d0e23 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -154,13 +154,13 @@ (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))) + ((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, @@ -269,7 +269,7 @@ (define-peg-pattern any-line body (define-peg-pattern identifier body (+ (and (not-followed-by (or NL WS punctuation)) peg-any))) (define-peg-pattern string-raw body - (and (ignore "`") (+ (and (not-followed-by "`") peg-any)) (ignore "`"))) + (and (ignore "`") (+ (and (not-followed-by "`") peg-any)) (ignore "`"))) (define-peg-pattern string-quoted body (and (ignore "\"") (+ (or (and (ignore "\\") peg-any) @@ -391,28 +391,28 @@ (define (make-vcs prefix 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 - (list - (make-vcs - "github.com" - "^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$" - 'git) - (make-vcs - "bitbucket.org" - "^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$" - 'unknown) - (make-vcs - "hub.jazz.net/git/" - "^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$" - 'git) - (make-vcs - "git.apache.org" - "^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$" - 'git) - (make-vcs - "git.openstack.org" - "^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\ + (list + (make-vcs + "github.com" + "^(github\\.com/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$" + 'git) + (make-vcs + "bitbucket.org" + "^(bitbucket\\.org/([A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+))(/[A-Za-z0-9_.\\-]+)*$" + 'unknown) + (make-vcs + "hub.jazz.net/git/" + "^(hub\\.jazz\\.net/git/[a-z0-9]+/[A-Za-z0-9_.\\-]+)(/[A-Za-z0-9_.\\-]+)*$" + 'git) + (make-vcs + "git.apache.org" + "^(git\\.apache\\.org/[a-z0-9_.\\-]+\\.git)(/[A-Za-z0-9_.\\-]+)*$" + 'git) + (make-vcs + "git.openstack.org" + "^(git\\.openstack\\.org/[A-Za-z0-9_.\\-]+/[A-Za-z0-9_.\\-]+)(\\.git)?\ (/[A-Za-z0-9_.\\-]+)*$" - 'git))) + 'git))) (define (module-path->repository-root module-path) "Infer the repository root from a module path. Go modules can be -- cgit v1.2.3 From aeded14b8342c1e72afd014a1bc121770f8c3a1c Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 2 Jul 2021 22:47:51 -0400 Subject: pack: Allow embedding custom control files in deb packs. * guix/scripts/pack.scm (self-contained-tarball/builder) [extra-options]: New argument. (self-contained-tarball, squashfs-image, docker-image) (debian-archive): Likewise. Remove two TODO comments. Document EXTRA-OPTIONS. Use the custom control files when provided. (%deb-format-options): New variable. (show-deb-format-options, show-deb-format-options/detailed): New procedures. (%options): Register new options. (show-help): Augment with new usage. (guix-pack): Validate and propagate new argument values. * doc/guix.texi (Invoking guix pack)[deb]: Document how to list advanced options. Add an example. * tests/pack.scm (deb archive...): Provide extra-options to the debian-archive procedure, and validate that the provided files are embedded in the pack. --- doc/guix.texi | 8 ++++ guix/scripts/pack.scm | 121 ++++++++++++++++++++++++++++++++++++++++++-------- tests/pack.scm | 27 ++++++++--- 3 files changed, 133 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index cca46218f2..b3c16e6507 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6047,6 +6047,14 @@ such file or directory'' message. This produces a Debian archive (a package with the @samp{.deb} file extension) containing all the specified binaries and symbolic links, that can be installed on top of any dpkg-based GNU(/Linux) distribution. +Advanced options can be revealed via the @option{--help-deb-format} +option. They allow embedding control files for more fine-grained +control, such as activating specific triggers or providing a maintainer +configure script to run arbitrary setup code upon installation. + +@example +guix pack -f deb -C xz -S /usr/bin/hello=bin/hello hello +@end example @quotation Note Because archives produced with @command{guix pack} contain a collection diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6d8b70d1c7..6a8d49e042 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -205,7 +205,8 @@ (define* (self-contained-tarball/builder profile (compressor (first %compressors)) localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "Return the G-Expression of the builder used for self-contained-tarball." (define database (and localstatedir? @@ -324,7 +325,8 @@ (define* (self-contained-tarball name profile (compressor (first %compressors)) localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "Return a self-contained tarball containing a store initialized with the closure of PROFILE, a derivation. The tarball contains /gnu/store; if LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db @@ -389,7 +391,8 @@ (define* (squashfs-image name profile entry-point localstatedir? (symlinks '()) - (archiver squashfs-tools)) + (archiver squashfs-tools) + (extra-options '())) "Return a squashfs image containing a store initialized with the closure of PROFILE, a derivation. The image contains a subset of /gnu/store, empty mount points for virtual file systems (like procfs), and optional symlinks. @@ -567,7 +570,8 @@ (define* (docker-image name profile entry-point localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "Return a derivation to construct a Docker image of PROFILE. The image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it @@ -654,8 +658,6 @@ (define directives ;;; TODO: When relocatable option is selected, install to a unique prefix. ;;; This would enable installation of multiple deb packs with conflicting ;;; files at the same time. -;;; TODO: Allow passing a custom control file from the CLI. -;;; TODO: Allow providing a postinst script. (define* (debian-archive name profile #:key target (profile-name "guix-profile") @@ -664,7 +666,8 @@ (define* (debian-archive name profile (compressor (first %compressors)) localstatedir? (symlinks '()) - (archiver tar)) + (archiver tar) + (extra-options '())) "Return a Debian archive (.deb) containing a store initialized with the closure of PROFILE, a derivation. The archive contains /gnu/store; if LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db @@ -672,7 +675,8 @@ (define* (debian-archive name profile \"none\", \"gz\" or \"xz\". SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be -added to the pack." +added to the pack. EXTRA-OPTIONS may contain the CONFIG-FILE, POSTINST-FILE +or TRIGGERS-FILE keyword arguments." ;; For simplicity, limit the supported compressors to the superset of ;; compressors able to compress both the control file (gz or xz) and the ;; data tarball (gz, bz2 or xz). @@ -714,21 +718,23 @@ (define build (guix build utils) (guix profiles) (ice-9 match) + ((oop goops) #:select (get-keyword)) (srfi srfi-1)) (define machine-type ;; Extract the machine type from the specified target, else from the ;; current system. - (and=> (or #$target %host-type) (lambda (triplet) - (first (string-split triplet #\-))))) + (and=> (or #$target %host-type) + (lambda (triplet) + (first (string-split triplet #\-))))) (define (gnu-machine-type->debian-machine-type type) "Translate machine TYPE from the GNU to Debian terminology." ;; Debian has its own jargon, different from the one used in GNU, for ;; machine types (see data/cputable in the sources of dpkg). (match type - ("i586" "i386") ("i486" "i386") + ("i586" "i386") ("i686" "i386") ("x86_64" "amd64") ("aarch64" "arm64") @@ -773,21 +779,40 @@ (define data-tarball-file-name (strip-store-file-name (copy-file #+data-tarball data-tarball-file-name) + ;; Generate the control archive. + (define control-file + (get-keyword #:control-file '#$extra-options)) + + (define postinst-file + (get-keyword #:postinst-file '#$extra-options)) + + (define triggers-file + (get-keyword #:triggers-file '#$extra-options)) + (define control-tarball-file-name (string-append "control.tar" #$(compressor-extension compressor))) ;; Write the compressed control tarball. Only the control file is ;; mandatory (see: 'man deb' and 'man deb-control'). - (call-with-output-file "control" - (lambda (port) - (format port "\ + (if control-file + (copy-file control-file "control") + (call-with-output-file "control" + (lambda (port) + (format port "\ Package: ~a Version: ~a Description: Debian archive generated by GNU Guix. Maintainer: GNU Guix Architecture: ~a -~%" package-name package-version architecture))) +~%" package-name package-version architecture)))) + + (when postinst-file + (copy-file postinst-file "postinst") + (chmod "postinst" #o755)) + + (when triggers-file + (copy-file triggers-file "triggers")) (define tar (string-append #+archiver "/bin/tar")) @@ -796,7 +821,9 @@ (define tar (string-append #+archiver "/bin/tar")) #:tar tar #:compressor '#+(and=> compressor compressor-command)) "-cvf" ,control-tarball-file-name - "control")) + "control" + ,@(if postinst-file '("postinst") '()) + ,@(if triggers-file '("triggers") '()))) ;; Create the .deb archive using GNU ar. (invoke (string-append #+binutils "/bin/ar") "-rv" #$output @@ -1157,6 +1184,34 @@ (define (show-formats) deb Debian archive installable via dpkg/apt")) (newline)) +(define %deb-format-options + (let ((required-option (lambda (symbol) + (option (list (symbol->string symbol)) #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest)))))) + (list (required-option 'control-file) + (required-option 'postinst-file) + (required-option 'triggers-file)))) + +(define (show-deb-format-options) + (display (G_ " + --help-deb-format list options specific to the deb format"))) + +(define (show-deb-format-options/detailed) + (display (G_ " + --control-file=FILE + Embed the provided control FILE")) + (display (G_ " + --postinst-file=FILE + Embed the provided postinst script")) + (display (G_ " + --triggers-file=FILE + Embed the provided triggers FILE")) + (newline) + (exit 0)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -1250,7 +1305,12 @@ (define %options (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) - (append %transformation-options + (option '("help-deb-format") #f #f + (lambda args + (show-deb-format-options/detailed))) + + (append %deb-format-options + %transformation-options %standard-build-options))) (define (show-help) @@ -1260,6 +1320,8 @@ (define (show-help) (newline) (show-transformation-options-help) (newline) + (show-deb-format-options) + (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " @@ -1369,6 +1431,18 @@ (define with-provenance (else (packages->manifest packages)))))) + (define (process-file-arg opts name) + ;; Validate that the file exists and return it as a object, + ;; else #f. + (let ((value (assoc-ref opts name))) + (match value + ((and (? string?) (not (? file-exists?))) + (leave (G_ "file provided with option ~a does not exist: ~a~%") + (string-append "--" (symbol->string name)) value)) + ((? string?) + (local-file value)) + (#f #f)))) + (with-error-handling (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) @@ -1401,6 +1475,15 @@ (define with-provenance manifest) manifest))) (pack-format (assoc-ref opts 'format)) + (extra-options (match pack-format + ('deb + (list #:control-file + (process-file-arg opts 'control-file) + #:postinst-file + (process-file-arg opts 'postinst-file) + #:triggers-file + (process-file-arg opts 'triggers-file))) + (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) (compressor (if bootstrap? @@ -1465,7 +1548,9 @@ (define (lookup-package package) #:profile-name profile-name #:archiver - archiver))) + archiver + #:extra-options + extra-options))) (mbegin %store-monad (mwhen derivation? (return (format #t "~a~%" diff --git a/tests/pack.scm b/tests/pack.scm index 9473d4f384..e9b4c36e0e 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -277,17 +277,25 @@ (define bin (built-derivations (list check)))) (unless store (test-skip 1)) - (test-assertm "deb archive with symlinks" store + (test-assertm "deb archive with symlinks and control files" store (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) (profile (profile-derivation (packages->manifest (list %bootstrap-guile)) #:hooks '() #:locales? #f)) - (deb (debian-archive "deb-pack" profile - #:compressor %gzip-compressor - #:symlinks '(("/opt/gnu/bin" -> "bin")) - #:archiver %tar-bootstrap)) + (deb (debian-archive + "deb-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/opt/gnu/bin" -> "bin")) + #:archiver %tar-bootstrap + #:extra-options + (list #:triggers-file + (plain-file "triggers" + "activate-noawait /usr/share/icons/hicolor\n") + #:postinst-file + (plain-file "postinst" + "echo running configure script\n")))) (check (gexp->derivation "check-deb-pack" (with-imported-modules '((guix build utils)) @@ -344,6 +352,15 @@ (define hard-links (unless (null? hard-links) (error "hard links found in data.tar.gz" hard-links)) + ;; Verify the presence of the control files. + (invoke "tar" "-xf" "control.tar.gz") + (assert (file-exists? "control")) + (assert (and (file-exists? "postinst") + (= #o111 ;script is executable + (logand #o111 (stat:perms + (stat "postinst")))))) + (assert (file-exists? "triggers")) + (mkdir #$output)))))) (built-derivations (list check))))) -- cgit v1.2.3 From b019496fc3643f0bd837c62078086e3ff51b6001 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 5 Jul 2021 20:03:58 -0400 Subject: pack/deb: Add default section and priority fields to the control file. These fields, while optional per dpkg, are required by other tools such as reprepro, commonly used to generate apt repositories. * guix/scripts/pack.scm (debian-archive): Set the control file section field to 'misc' and the priority field to 'optional'. --- guix/scripts/pack.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6a8d49e042..78201d6f5f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -805,6 +805,8 @@ (define control-tarball-file-name Description: Debian archive generated by GNU Guix. Maintainer: GNU Guix Architecture: ~a +Priority: optional +Section: misc ~%" package-name package-version architecture)))) (when postinst-file -- cgit v1.2.3 From 11f0698243da27be93b16cec574fbf262279779a Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 6 Jul 2021 12:27:36 -0400 Subject: pack: Streamline how files are included in tarballs. Thanks to Guillem Jover on the OFTC's #debian-dpkg channel for helping with troubleshooting. Letting GNU Tar recursively walk the complete files hierarchy side-steps the risks associated with providing a list of file names: 1. Duplicated files in the archive (recorded as hard links by GNU Tar) 2. Missing parent directories. The above would cause dpkg to malfunction, for example by aborting early and skipping triggers when there were missing parent directories. * guix/scripts/pack.scm (self-contained-tarball/builder): Do not call POPULATE-SINGLE-PROFILE-DIRECTORY, which creates extraneous files such as /root. Instead, call POPULATE-STORE and INSTALL-DATABASE-AND-GC-ROOTS individually to more precisely generate the file system. Replace the list of files by the current directory, "." and streamline the way options are passed. * gnu/system/file-systems.scm (reduce-directories): Remove procedure. * tests/file-systems.scm ("reduce-directories"): Remove test. --- gnu/system/file-systems.scm | 22 -------------------- guix/scripts/pack.scm | 49 +++++++++++++++------------------------------ tests/file-systems.scm | 7 +------ 3 files changed, 17 insertions(+), 61 deletions(-) (limited to 'guix') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 4a3c1fe008..b9eda80958 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -55,7 +55,6 @@ (define-module (gnu system file-systems) file-system-dependencies file-system-location - reduce-directories file-system-type-predicate btrfs-subvolume? btrfs-store-subvolume-file-name @@ -266,27 +265,6 @@ (define (absolute? file) (define (file-name-depth file-name) (length (string-tokenize file-name %not-slash))) -(define (reduce-directories file-names) - "Eliminate entries in FILE-NAMES that are children of other entries in -FILE-NAMES. This is for example useful when passing a list of files to GNU -tar, which would otherwise descend into each directory passed and archive the -duplicate files as hard links, which can be undesirable." - (let* ((file-names/sorted - ;; Ascending sort by file hierarchy depth, then by file name length. - (stable-sort (delete-duplicates file-names) - (lambda (f1 f2) - (let ((depth1 (file-name-depth f1)) - (depth2 (file-name-depth f2))) - (if (= depth1 depth2) - (string< f1 f2) - (< depth1 depth2))))))) - (reverse (fold (lambda (file-name results) - (if (find (cut file-prefix? <> file-name) results) - results ;parent found -- skipping - (cons file-name results))) - '() - file-names/sorted)))) - (define* (file-system-device->string device #:key uuid-type) "Return the string representations of the DEVICE field of a record. When the device is a UUID, its representation is chosen depending on diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 78201d6f5f..9e1f270dfb 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -231,17 +231,17 @@ (define (import-module? module) (with-imported-modules (source-module-closure `((guix build pack) + (guix build store-copy) (guix build utils) (guix build union) - (gnu build install) - (gnu system file-systems)) + (gnu build install)) #:select? import-module?) #~(begin (use-modules (guix build pack) + (guix build store-copy) (guix build utils) ((guix build union) #:select (relative-file-name)) (gnu build install) - ((gnu system file-systems) #:select (reduce-directories)) (srfi srfi-1) (srfi srfi-26) (ice-9 match)) @@ -279,11 +279,11 @@ (define tar #+(file-append archiver "/bin/tar")) ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs ;; with hard links: ;; . - (populate-single-profile-directory %root - #:profile #$profile - #:profile-name #$profile-name - #:closure "profile" - #:database #+database) + (populate-store (list "profile") %root #:deduplicate? #f) + + (when #+localstatedir? + (install-database-and-gc-roots %root #+database #$profile + #:profile-name #$profile-name)) ;; Create SYMLINKS. (for-each (cut evaluate-populate-directive <> %root) @@ -291,31 +291,14 @@ (define tar #+(file-append archiver "/bin/tar")) ;; Create the tarball. (with-directory-excursion %root - (apply invoke tar - `(,@(tar-base-options - #:tar tar - #:compressor '#+(and=> compressor compressor-command)) - "-cvf" ,#$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - ,#$@(if localstatedir? - '("./var/guix") - '()) - - ,(string-append "." (%store-directory)) - - ,@(reduce-directories - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives)))))))) + ;; GNU Tar recurses directories by default. Simply add the whole + ;; current directory, which contains all the generated files so far. + ;; This avoids creating duplicate files in the archives that would + ;; be stored as hard links by GNU Tar. + (apply invoke tar "-cvf" #$output "." + (tar-base-options + #:tar tar + #:compressor '#+(and=> compressor compressor-command))))))) (define* (self-contained-tarball name profile #:key target diff --git a/tests/file-systems.scm b/tests/file-systems.scm index 80acb6d5b9..7f7c373884 100644 --- a/tests/file-systems.scm +++ b/tests/file-systems.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Ludovic Courtès -;;; Copyright © 2020, 2021 Maxim Cournoyer +;;; Copyright © 2020 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,11 +50,6 @@ (define-module (test-file-systems) (device "/foo") (flags '(bind-mount read-only))))))))) -(test-equal "reduce-directories" - '("./opt/gnu/" "./opt/gnuism" "a/b/c") - (reduce-directories '("./opt/gnu/etc" "./opt/gnu/" "./opt/gnu/bin" - "./opt/gnu/lib/debug" "./opt/gnuism" "a/b/c" "a/b/c"))) - (test-assert "does not pull (guix config)" ;; This module is meant both for the host side and "build side", so make ;; sure it doesn't pull in (guix config), which depends on the user's -- cgit v1.2.3 From c170abba4735a2c8a6845063fae8bf090975cbf9 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 6 Jul 2021 14:32:56 -0400 Subject: build: pack: Mute error output when checking if tar supports --sort. * guix/build/pack.scm (tar-base-options) [tar-supports-sort?]: Redirect error output to void. --- guix/build/pack.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/pack.scm b/guix/build/pack.scm index 05c7a3c594..3b73d1b227 100644 --- a/guix/build/pack.scm +++ b/guix/build/pack.scm @@ -27,8 +27,10 @@ (define* (tar-base-options #:key tar compressor) '(\"gzip\" \"-9n\"), is provided, the compressor is explicitly specified via the `-I' option." (define (tar-supports-sort? tar) - (zero? (system* tar "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) + (with-error-to-port (%make-void-port "w") + (lambda () + (zero? (system* tar "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))))) `(,@(if compressor (list "-I" (string-join compressor)) -- cgit v1.2.3