From 82d8959e5d137b2061a68878d78a8f74a238ac44 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 Apr 2020 17:34:38 +0200 Subject: syscalls: 'readdir*' chooses between the Linux and Hurd code at run time. Partly fixes . Reported by Jan Nieuwenhuizen . Previously, we'd choose at expansion time whether to use the Hurd or the Linux variant, taking the cross-compilation target into account. This would lead to the wrong decision when (guix build syscalls) is evaluated while we're cross-compiling to GNU/Hurd. This is a followup to 1ab9e483391f8b62b873833ea71cb0074efa03e7. * guix/build/syscalls.scm (define-generic-identifier) (read-dirent-header, %struct-dirent-header, sizeof-dirent-header): Remove. (readdir*): Rename to... (readdir-procedure): ... this, and add parameters. (readdir*): Define as a call to 'readdir-procedure' as a function of %HOST-TYPE. --- guix/build/syscalls.scm | 50 +++++++++++++++---------------------------------- 1 file changed, 15 insertions(+), 35 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 0938ec0ff1..7ef03417c1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -22,7 +22,6 @@ (define-module (guix build syscalls) #:use-module (system foreign) - #:use-module (system base target) ;for cross-compilation support #:use-module (rnrs bytevectors) #:autoload (ice-9 binary-ports) (get-bytevector-n) #:use-module (srfi srfi-1) @@ -892,36 +891,6 @@ system to PUT-OLD." (namelen uint8) (name uint8)) -(define-syntax define-generic-identifier - (syntax-rules (gnu/linux gnu/hurd =>) - "Define a generic identifier that adjust to the current GNU variant." - ((_ id (gnu/linux => linux) (gnu/hurd => hurd)) - (define-syntax id - (lambda (s) - (syntax-case s () - ((_ args (... ...)) - (if (string-contains (or (target-type) %host-type) - "linux") - #'(linux args (... ...)) - #'(hurd args (... ...)))) - (_ - (if (string-contains (or (target-type) %host-type) - "linux") - #'linux - #'hurd)))))))) - -(define-generic-identifier read-dirent-header - (gnu/linux => read-dirent-header/linux) - (gnu/hurd => read-dirent-header/hurd)) - -(define-generic-identifier %struct-dirent-header - (gnu/linux => %struct-dirent-header/linux) - (gnu/hurd => %struct-dirent-header/hurd)) - -(define-generic-identifier sizeof-dirent-header - (gnu/linux => sizeof-dirent-header/linux) - (gnu/hurd => sizeof-dirent-header/hurd)) - ;; Constants for the 'type' field, from . (define DT_UNKNOWN 0) (define DT_FIFO 1) @@ -960,19 +929,30 @@ system to PUT-OLD." "closedir: ~A" (list (strerror err)) (list err))))))) -(define readdir* +(define (readdir-procedure name-field-offset sizeof-dirent-header + read-dirent-header) (let ((proc (syscall->procedure '* "readdir64" '(*)))) (lambda* (directory #:optional (pointer->string pointer->string/utf-8)) (let ((ptr (proc directory))) (and (not (null-pointer? ptr)) (cons (pointer->string - (make-pointer (+ (pointer-address ptr) - (c-struct-field-offset - %struct-dirent-header name))) + (make-pointer (+ (pointer-address ptr) name-field-offset)) -1) (read-dirent-header (pointer->bytevector ptr sizeof-dirent-header)))))))) +(define readdir* + ;; Decide at run time which one must be used. + (if (string-suffix? "linux-gnu" %host-type) + (readdir-procedure (c-struct-field-offset %struct-dirent-header/linux + name) + sizeof-dirent-header/linux + read-dirent-header/linux) + (readdir-procedure (c-struct-field-offset %struct-dirent-header/hurd + name) + sizeof-dirent-header/hurd + read-dirent-header/hurd))) + (define* (scandir* name #:optional (select? (const #t)) (entry Date: Tue, 14 Apr 2020 17:23:33 +0200 Subject: import/print: Return license with prefix. * guix/import/print.scm (license->code): Prepend license: prefix. --- guix/import/print.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index 4c2a91fa4f..b819e7cf90 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2017, 2020 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,7 +57,7 @@ when evaluated." ;; Print either license variable name or the code for a license object (define (license->code lic) (let ((var (variable-name lic '(guix licenses)))) - (or var + (or (symbol-append 'license: var) `(license (name ,(license-name lic)) (uri ,(license-uri lic)) -- cgit v1.2.3 From 6269dd567e85c78a87be8d55f7ddc801a0ea870c Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 14 Apr 2020 17:24:09 +0200 Subject: import/print: package->code: Wrap build system value in module reference. * guix/import/print.scm (package->code): Return build system value with corresponding module. --- guix/import/print.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index b819e7cf90..4529a79b23 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -131,8 +131,9 @@ when evaluated." ,@(if replacement `((replacement ,replacement)) '()) - (build-system ,(symbol-append (build-system-name build-system) - '-build-system)) + (build-system (@ (guix build-system ,(build-system-name build-system)) + ,(symbol-append (build-system-name build-system) + '-build-system))) ,@(match arguments (() '()) (args `((arguments ,(list 'quasiquote args))))) -- cgit v1.2.3 From 16dd764691d7f3ab954c82332f456bfa5f094514 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 14 Apr 2020 18:01:11 +0200 Subject: import/json: Add json->scheme-file. * guix/import/json.scm (json->code, json->scheme-file): New procedures. --- guix/import/json.scm | 35 ++++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/json.scm b/guix/import/json.scm index 8900724dcd..16dc2ad5cb 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014 David Thompson ;;; Copyright © 2015, 2016 Eric Bavier ;;; Copyright © 2018, 2019 Ludovic Courtès +;;; Copyright © 2020 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,8 +23,12 @@ #:use-module (json) #:use-module (guix http-client) #:use-module (guix import utils) + #:use-module (guix import print) + #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-34) - #:export (json-fetch)) + #:export (json-fetch + json->scheme-file)) (define* (json-fetch url ;; Note: many websites returns 403 if we omit a @@ -42,3 +47,31 @@ the query." (result (json->scm port))) (close-port port) result))) + +(define (json->code file-name) + "Read FILE-NAME containing a JSON package definition and return an +S-expression, or return #F when the JSON is invalid." + (catch 'json-invalid + (lambda () + (let ((json (json-string->scm + (with-input-from-file file-name read-string)))) + (package->code (alist->package json)))) + (const #f))) + +(define (json->scheme-file file) + "Convert the FILE containing a JSON package definition to a Scheme +representation and return the new file name (or #F on error)." + (and-let* ((json (json->code file)) + (file* (let* ((tempdir (or (getenv "TMPDIR") "/tmp")) + (template (string-append tempdir "/guix-XXXXXX")) + (port (mkstemp! template))) + (close-port port) + template))) + (call-with-output-file file* + (lambda (port) + (write '(use-modules (gnu) + (guix) + ((guix licenses) #:prefix license:)) + port) + (write json port))) + file*)) -- cgit v1.2.3 From f87e56320198fecd81ce588f571578b6cda5ed08 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 14 Apr 2020 18:01:49 +0200 Subject: scripts/build: options->things-to-build: Handle .json files. * guix/scripts/build.scm (options->things-to-build): Handle files that end on .json. --- guix/scripts/build.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 79bd84a1a0..8ff2fd1910 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; Copyright © 2020 Marius Bakke +;;; Copyright © 2020 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ (define-module (guix scripts build) #:use-module (guix ui) #:use-module (guix scripts) + #:use-module (guix import json) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) @@ -834,7 +836,10 @@ build---packages, gexps, derivations, and so on." (else (list (specification->package spec))))) (('file . file) - (ensure-list (load* file (make-user-module '())))) + (let ((file (or (and (string-suffix? ".json" file) + (json->scheme-file file)) + file))) + (ensure-list (load* file (make-user-module '()))))) (('manifest . manifest) (map manifest-entry-item (manifest-entries -- cgit v1.2.3 From 4f353c485dea4b549a0aabd1c87b0dd03fef4f1e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 14 Apr 2020 18:02:26 +0200 Subject: scripts/package: Handle JSON files. * guix/scripts/package.scm (%options): Support loading from JSON files when "install-from-file" is used. --- guix/scripts/package.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index badb1dcd38..40445832aa 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2016 Benz Schenk ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2019 Tobias Geerinckx-Rice +;;; Copyright © 2020 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,6 +34,7 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix search-paths) + #:use-module (guix import json) #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix config) @@ -418,7 +420,10 @@ Install, remove, or upgrade packages in a single transaction.\n")) (option '(#\f "install-from-file") #t #f (lambda (opt name arg result arg-handler) (values (alist-cons 'install - (load* arg (make-user-module '())) + (let ((file (or (and (string-suffix? ".json" arg) + (json->scheme-file arg)) + arg))) + (load* file (make-user-module '()))) result) #f))) (option '(#\r "remove") #f #t -- cgit v1.2.3 From c89343232065c50d196cd194073d2034eaedaf44 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 15 Apr 2020 00:38:15 +0200 Subject: import/json: Use json->code. * guix/import/json.scm (json->code): Export procedure. * guix/scripts/import/json.scm (guix-import-json): Use json->code. --- guix/import/json.scm | 1 + guix/scripts/import/json.scm | 12 +++--------- 2 files changed, 4 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/import/json.scm b/guix/import/json.scm index 16dc2ad5cb..8f8dbbd05d 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-34) #:export (json-fetch + json->code json->scheme-file)) (define* (json-fetch url diff --git a/guix/scripts/import/json.scm b/guix/scripts/import/json.scm index c9daf65479..778e5f4bc5 100644 --- a/guix/scripts/import/json.scm +++ b/guix/scripts/import/json.scm @@ -23,7 +23,7 @@ #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix import utils) - #:use-module (guix import print) + #:use-module (guix import json) #:use-module (guix scripts import) #:use-module (guix packages) #:use-module (srfi srfi-1) @@ -88,14 +88,8 @@ Import and convert the JSON package definition in PACKAGE-FILE.\n")) (reverse opts)))) (match args ((file-name) - (catch 'json-invalid - (lambda () - (let ((json (json-string->scm - (with-input-from-file file-name read-string)))) - ;; TODO: also print define-module boilerplate - (package->code (alist->package json)))) - (lambda _ - (leave (G_ "invalid JSON in file '~a'~%") file-name)))) + (or (json->code file-name) + (leave (G_ "invalid JSON in file '~a'~%") file-name))) (() (leave (G_ "too few arguments~%"))) ((many ...) -- cgit v1.2.3 From 86a3b540d08e0ece2a697f7caa6342a55394a6b3 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 15 Apr 2020 00:39:45 +0200 Subject: import/print: package->code: Wrap S-expression in definition. * guix/import/print.scm (package->code): Return a definition, not just a package expression. --- guix/import/print.scm | 87 ++++++++++++++++++++++++++------------------------- 1 file changed, 44 insertions(+), 43 deletions(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index 4529a79b23..08f3ec9c34 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -121,46 +121,47 @@ when evaluated." (home-page (package-home-page package)) (supported-systems (package-supported-systems package)) (properties (package-properties package))) - `(package - (name ,name) - (version ,version) - (source ,(source->code source version)) - ,@(match properties - (() '()) - (_ `((properties ,properties)))) - ,@(if replacement - `((replacement ,replacement)) - '()) - (build-system (@ (guix build-system ,(build-system-name build-system)) - ,(symbol-append (build-system-name build-system) - '-build-system))) - ,@(match arguments - (() '()) - (args `((arguments ,(list 'quasiquote args))))) - ,@(match outputs - (("out") '()) - (outs `((outputs (list ,@outs))))) - ,@(match native-inputs - (() '()) - (pkgs `((native-inputs ,(package-lists->code pkgs))))) - ,@(match inputs - (() '()) - (pkgs `((inputs ,(package-lists->code pkgs))))) - ,@(match propagated-inputs - (() '()) - (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) - ,@(if (lset= string=? supported-systems %supported-systems) - '() - `((supported-systems (list ,@supported-systems)))) - ,@(match (map search-path-specification->code native-search-paths) - (() '()) - (paths `((native-search-paths (list ,@paths))))) - ,@(match (map search-path-specification->code search-paths) - (() '()) - (paths `((search-paths (list ,@paths))))) - (home-page ,home-page) - (synopsis ,synopsis) - (description ,description) - (license ,(if (list? license) - `(list ,@(map license->code license)) - (license->code license)))))) + `(define-public ,(string->symbol name) + (package + (name ,name) + (version ,version) + (source ,(source->code source version)) + ,@(match properties + (() '()) + (_ `((properties ,properties)))) + ,@(if replacement + `((replacement ,replacement)) + '()) + (build-system (@ (guix build-system ,(build-system-name build-system)) + ,(symbol-append (build-system-name build-system) + '-build-system))) + ,@(match arguments + (() '()) + (args `((arguments ,(list 'quasiquote args))))) + ,@(match outputs + (("out") '()) + (outs `((outputs (list ,@outs))))) + ,@(match native-inputs + (() '()) + (pkgs `((native-inputs ,(package-lists->code pkgs))))) + ,@(match inputs + (() '()) + (pkgs `((inputs ,(package-lists->code pkgs))))) + ,@(match propagated-inputs + (() '()) + (pkgs `((propagated-inputs ,(package-lists->code pkgs))))) + ,@(if (lset= string=? supported-systems %supported-systems) + '() + `((supported-systems (list ,@supported-systems)))) + ,@(match (map search-path-specification->code native-search-paths) + (() '()) + (paths `((native-search-paths (list ,@paths))))) + ,@(match (map search-path-specification->code search-paths) + (() '()) + (paths `((search-paths (list ,@paths))))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,(if (list? license) + `(list ,@(map license->code license)) + (license->code license))))))) -- cgit v1.2.3 From 3532fc39fff41eabd061370ee36a1d42b9fac0e6 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 15 Apr 2020 00:41:03 +0200 Subject: import/utils: alist->package: Ignore known inputs. * guix/import/utils.scm (alist->package): Accept optional list of known inputs, which are excluded from the specification lookup. * guix/import/print.scm (package->code)[package-lists->code]: Handle inputs which are just symbols. --- guix/import/print.scm | 2 ++ guix/import/utils.scm | 27 ++++++++++++++++----------- 2 files changed, 18 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index 08f3ec9c34..471687c0ff 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -92,6 +92,8 @@ when evaluated." (define (package-lists->code lsts) (list 'quasiquote (map (match-lambda + ((? symbol? s) + (list (symbol->string s) (list 'unquote s))) ((label pkg . out) (let ((mod (package-module-name pkg))) (cons* label diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 94c8cb040b..5fb1322535 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Jelle Licht ;;; Copyright © 2016 David Craven -;;; Copyright © 2017, 2019 Ricardo Wurmus +;;; Copyright © 2017, 2019, 2020 Ricardo Wurmus ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2019 Robert Vollmert ;;; @@ -310,7 +310,18 @@ the expected fields of an object." (uri (assoc-ref orig "uri")) (sha256 sha)))))) -(define (alist->package meta) +(define* (alist->package meta #:optional (known-inputs '())) + "Return a package value generated from the alist META. If the list of +strings KNOWN-INPUTS is provided, do not treat the mentioned inputs as +specifications to look up and replace them with plain symbols instead." + (define (process-inputs which) + (let-values (((regular known) + (lset-diff+intersection + string=? + (vector->list (or (assoc-ref meta which) #())) + known-inputs))) + (append (specs->package-lists regular) + (map string->symbol known)))) (package (name (assoc-ref meta "name")) (version (assoc-ref meta "version")) @@ -318,15 +329,9 @@ the expected fields of an object." (build-system (lookup-build-system-by-name (string->symbol (assoc-ref meta "build-system")))) - (native-inputs - (specs->package-lists - (vector->list (or (assoc-ref meta "native-inputs") '#())))) - (inputs - (specs->package-lists - (vector->list (or (assoc-ref meta "inputs") '#())))) - (propagated-inputs - (specs->package-lists - (vector->list (or (assoc-ref meta "propagated-inputs") '#())))) + (native-inputs (process-inputs "native-inputs")) + (inputs (process-inputs "inputs")) + (propagated-inputs (process-inputs "propagated-inputs")) (home-page (assoc-ref meta "home-page")) (synopsis -- cgit v1.2.3 From 7cef499bb060aabf3d59cc4eca37350e5c79ff7d Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 15 Apr 2020 00:43:39 +0200 Subject: import/json: json->code: Handle files with more than one definition. * guix/import/json.scm (json->code): Convert JSON arrays to lists of package definitions. (json->scheme-file): Write all expressions to the target file. --- guix/import/json.scm | 35 ++++++++++++++++++++++++++++++----- 1 file changed, 30 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/import/json.scm b/guix/import/json.scm index 8f8dbbd05d..0c98bb25b8 100644 --- a/guix/import/json.scm +++ b/guix/import/json.scm @@ -24,8 +24,11 @@ #:use-module (guix http-client) #:use-module (guix import utils) #:use-module (guix import print) + #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:export (json-fetch json->code @@ -50,19 +53,41 @@ the query." result))) (define (json->code file-name) - "Read FILE-NAME containing a JSON package definition and return an -S-expression, or return #F when the JSON is invalid." + "Read FILE-NAME containing one ore more JSON package definitions and return +a list of S-expressions, or return #F when the JSON is invalid." (catch 'json-invalid (lambda () (let ((json (json-string->scm (with-input-from-file file-name read-string)))) - (package->code (alist->package json)))) + (match json + (#(packages ...) + ;; To allow definitions to refer to one another, collect references + ;; to local definitions and tell alist->package to ignore them. + (second + (memq #:result + (fold + (lambda (pkg names+result) + (match names+result + ((#:names names #:result result) + (list #:names + (cons (assoc-ref pkg "name") names) + #:result + (append result + (list + (package->code (alist->package pkg names)) + (string->symbol (assoc-ref pkg "name")))))))) + (list #:names '() + #:result '()) + packages)))) + (package + (list (package->code (alist->package json)) + (string->symbol (assoc-ref json "name"))))))) (const #f))) (define (json->scheme-file file) "Convert the FILE containing a JSON package definition to a Scheme representation and return the new file name (or #F on error)." - (and-let* ((json (json->code file)) + (and-let* ((sexprs (json->code file)) (file* (let* ((tempdir (or (getenv "TMPDIR") "/tmp")) (template (string-append tempdir "/guix-XXXXXX")) (port (mkstemp! template))) @@ -74,5 +99,5 @@ representation and return the new file name (or #F on error)." (guix) ((guix licenses) #:prefix license:)) port) - (write json port))) + (for-each (cut write <> port) sexprs))) file*)) -- cgit v1.2.3 From 3fd4c4c8394bca7aa9dd81c0ad81f2bb31989464 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 16 Apr 2020 21:44:21 +0200 Subject: import/utils: alist->package: Include arguments. * guix/import/utils.scm (alist->package): Process arguments field in input data and include it in the generated package. --- guix/import/utils.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 5fb1322535..3809c3d074 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -322,6 +322,11 @@ specifications to look up and replace them with plain symbols instead." known-inputs))) (append (specs->package-lists regular) (map string->symbol known)))) + (define (process-arguments arguments) + (append-map (match-lambda + ((key . value) + (list (symbol->keyword (string->symbol key)) value))) + arguments)) (package (name (assoc-ref meta "name")) (version (assoc-ref meta "version")) @@ -329,6 +334,10 @@ specifications to look up and replace them with plain symbols instead." (build-system (lookup-build-system-by-name (string->symbol (assoc-ref meta "build-system")))) + (arguments + (or (and=> (assoc-ref meta "arguments") + process-arguments) + '())) (native-inputs (process-inputs "native-inputs")) (inputs (process-inputs "inputs")) (propagated-inputs (process-inputs "propagated-inputs")) -- cgit v1.2.3 From 3c0422b9be649e0a09caa0b893713a9f07855cd3 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 16 Apr 2020 22:09:41 +0200 Subject: import/print: Don't factorize URI if there's no version match. * guix/import/print.scm (package->code): If FACTORIZE-URI returns just the unmodified string use that as the URI. --- guix/import/print.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index 471687c0ff..11cc218285 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -79,7 +79,9 @@ when evaluated." (patches (origin-patches source))) `(origin (method ,(procedure-name method)) - (uri (string-append ,@(factorize-uri uri version))) + (uri (string-append ,@(match (factorize-uri uri version) + ((? string? uri) (list uri)) + (factorized factorized)))) (sha256 (base32 ,(format #f "~a" (bytevector->nix-base32-string sha256)))) -- cgit v1.2.3 From 8fa4ac5be4d5f8a1e62635842b16486832ff49f1 Mon Sep 17 00:00:00 2001 From: TomZ Date: Tue, 7 Apr 2020 21:39:04 +0200 Subject: status: Allow double-click select of URLs. Various places while downloading or compiling guix prints the source URL. This change makes the URL easier to use by placing a space between the URL and the trailing dots. Signed-off-by: Marius Bakke --- guix/status.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 4b2edc2f3c..45e441eac5 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -472,16 +472,16 @@ addition to build events." (let ((count (match (assq-ref properties 'graft) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "applying ~a graft for ~a..." - "applying ~a grafts for ~a..." + (format port (info (N_ "applying ~a graft for ~a ..." + "applying ~a grafts for ~a ..." count)) count drv))) ('profile (let ((count (match (assq-ref properties 'profile) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "building profile with ~a package..." - "building profile with ~a packages..." + (format port (info (N_ "building profile with ~a package ..." + "building profile with ~a packages ..." count)) count))) ('profile-hook @@ -525,7 +525,7 @@ addition to build events." (newline port))) (('download-started item uri _ ...) (erase-current-line*) - (format port (info (G_ "downloading from ~a...")) uri) + (format port (info (G_ "downloading from ~a ...")) uri) (newline port)) (('download-progress item uri (= string->number size) -- cgit v1.2.3 From 694e10af639da64cdf6f1c44cadf9a64f8a04fa6 Mon Sep 17 00:00:00 2001 From: Vincent Legoll Date: Thu, 16 Apr 2020 23:17:16 +0200 Subject: ui: Fix typos, 80-col & grammar in comments & docstrings. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/ui.scm (load*): Fix comment line length. (leave-on-EPIPE): Fix typo in docstring. (substitutable-info): Fix typo in comment. (indented-string): Fix typo in docstring. (%package-metrics): Fix typo in comment. (run-guix): Fix grammar in docstring. Signed-off-by: Ludovic Courtès --- guix/ui.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 1ccc80a000..ea5f460865 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -234,8 +234,8 @@ information, or #f if it could not be found." ;; Give 'load' an absolute file name so that it doesn't try to ;; search for FILE in %LOAD-PATH. Note: use 'load', not - ;; 'primitive-load', so that FILE is compiled, which then allows us - ;; to provide better error reporting with source line numbers. + ;; 'primitive-load', so that FILE is compiled, which then allows + ;; us to provide better error reporting with source line numbers. (load (canonicalize-path file))) (const #f)))))) (lambda _ @@ -796,7 +796,7 @@ directories:~{ ~a~}~%") (apply format #f format-string format-args)))))) (define-syntax-rule (leave-on-EPIPE exp ...) - "Run EXP... in a context when EPIPE errors are caught and lead to 'exit' + "Run EXP... in a context where EPIPE errors are caught and lead to 'exit' with successful exit code. This is useful when writing to the standard output may lead to EPIPE, because the standard output is piped through 'head' or similar." @@ -925,7 +925,7 @@ download." drv)) (define substitutable-info - ;; Call 'substitutation-oracle' upfront so we don't end up launching the + ;; Call 'substitution-oracle' upfront so we don't end up launching the ;; substituter many times. This makes a big difference, especially when ;; DRV is a long list as is the case with 'guix environment'. (if use-substitutes? @@ -1251,7 +1251,7 @@ separator between subsequent columns." (define* (indented-string str indent #:key (initial-indent? #t)) - "Return STR with each newline preceded by IDENT spaces. When + "Return STR with each newline preceded by INDENT spaces. When INITIAL-INDENT? is true, the first line is also indented." (define indent-string (make-list indent #\space)) @@ -1534,7 +1534,7 @@ score, the more relevant OBJ is to REGEXPS." (,(lambda (package) (filter (lambda (output) (not (member output - ;; Some common outpus shared by many packages. + ;; Some common outputs shared by many packages. '("out" "doc" "debug" "lib" "include" "bin")))) (package-outputs package))) . 1) @@ -1942,7 +1942,7 @@ found." (define (run-guix . args) "Run the 'guix' command defined by command line ARGS. Unlike 'guix-main', this procedure assumes that locale, i18n support, -and signal handling has already been set up." +and signal handling have already been set up." (define option? (cut string-prefix? "-" <>)) ;; The default %LOAD-EXTENSIONS includes the empty string, which doubles the -- cgit v1.2.3 From aa78c596c9eaae946f779d8fa3c4125d08187648 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Fri, 17 Apr 2020 23:25:17 +0200 Subject: gnupg: Accept revoked keys. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit I (nckx) have revoked all RSA subkeys, in favour of my older and freshly-refreshed ECDSA ones. This was merely a precaution: to my knowledge all my RSA private keys have been carefully destroyed and were never compromised. This commit keeps ‘make authenticate’ happy. * guix/gnupg.scm (revkeysig-rx): New variable for revoked keys. (gnupg-verify): Parse it. (gnupg-status-good-signature?): Accept it as ‘good’ for our purposes. * build-aux/git-authenticate.scm (%committers): Clarify nckx's subkeys. Signed-off-by: Ludovic Courtès --- build-aux/git-authenticate.scm | 7 ++++--- guix/gnupg.scm | 11 ++++++++++- 2 files changed, 14 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/build-aux/git-authenticate.scm b/build-aux/git-authenticate.scm index 37e0c6800c..bb48dddc59 100644 --- a/build-aux/git-authenticate.scm +++ b/build-aux/git-authenticate.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020 Ludovic Courtès +;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -147,11 +148,11 @@ ("mthl" "F2A3 8D7E EB2B 6640 5761 070D 0ADE E100 9460 4D37") ("nckx" - ;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B" - "7E8F AED0 0944 78EF 72E6 4D16 D889 B0F0 18C5 493C") - ("nckx (2nd)" ;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B" "F5DA 2032 4B87 3D0B 7A38 7672 0DB0 FF88 4F55 6D79") + ("nckx (revoked; not compromised)" + ;; primary: "F5BC 5534 C36F 0087 B39D 36EF 1C9D C4FE B9DB 7C4B" + "7E8F AED0 0944 78EF 72E6 4D16 D889 B0F0 18C5 493C") ("niedzejkob" "E576 BFB2 CF6E B13D F571 33B9 E315 A758 4613 1564") ("ngz" diff --git a/guix/gnupg.scm b/guix/gnupg.scm index bf0283f8fe..5fae24b325 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2013, 2014, 2016, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -71,6 +72,8 @@ "^\\[GNUPG:\\] VALIDSIG ([[:xdigit:]]+) ([[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2}) ([[:digit:]]+) .*$")) (define expkeysig-rx ; good signature, but expired key (make-regexp "^\\[GNUPG:\\] EXPKEYSIG ([[:xdigit:]]+) (.*)$")) +(define revkeysig-rx ; good signature, but revoked key + (make-regexp "^\\[GNUPG:\\] REVKEYSIG ([[:xdigit:]]+) (.*)$")) (define errsig-rx ;; Note: The fingeprint part (the last element of the line) appeared in ;; GnuPG 2.2.7 according to 'doc/DETAILS', and it may be missing. @@ -114,6 +117,11 @@ revoked. Return a status s-exp if GnuPG failed." (lambda (match) `(expired-key-signature ,(match:substring match 1) ; fingerprint ,(match:substring match 2)))) ; user name + ((regexp-exec revkeysig-rx line) + => + (lambda (match) + `(revoked-key-signature ,(match:substring match 1) ; fingerprint + ,(match:substring match 2)))) ; user name ((regexp-exec errsig-rx line) => (lambda (match) @@ -157,7 +165,8 @@ a fingerprint/user pair; return #f otherwise." (match (assq 'valid-signature status) (('valid-signature fingerprint date timestamp) (match (or (assq 'good-signature status) - (assq 'expired-key-signature status)) + (assq 'expired-key-signature status) + (assq 'revoked-key-signature status)) ((_ key-id user) (cons fingerprint user)) (_ #f))) (_ -- cgit v1.2.3 From 04594054d6cddb985cb1bfce1c84372c81f87636 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 18 Apr 2020 23:21:34 +0200 Subject: status: Remove extra space before ellipsis. Extra space was introduced in 8fa4ac5be4d5f8a1e62635842b16486832ff49f1. * guix/status.scm (print-build-event): Remove extra space before ellipsis. --- guix/status.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 45e441eac5..f40d5d59b9 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -480,8 +480,8 @@ addition to build events." (let ((count (match (assq-ref properties 'profile) (#f 0) (lst (or (assq-ref lst 'count) 0))))) - (format port (info (N_ "building profile with ~a package ..." - "building profile with ~a packages ..." + (format port (info (N_ "building profile with ~a package..." + "building profile with ~a packages..." count)) count))) ('profile-hook -- cgit v1.2.3 From 3c91f003416c9fb79af2dc8766a7f449aa03f839 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Apr 2020 13:16:52 +0200 Subject: tests: Invoke 'git' with a custom '.gitconfig' and ignore the system config. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Gábor Boskovits . * guix/tests/git.scm (call-with-environment-variables): New procedure. (with-environment-variables): New macro. (populate-git-repository)[git]: Wrap (git-command) invocation in 'call-with-temporary-directory' and 'with-environment-variables'. --- guix/tests/git.scm | 37 ++++++++++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 21573ac14e..566660e85e 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès +;;; Copyright © 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +30,24 @@ (define git-command (make-parameter "git")) +(define (call-with-environment-variables variables thunk) + "Call THUNK with the environment VARIABLES set." + (let ((environment (environ))) + (dynamic-wind + (lambda () + (for-each (match-lambda + ((variable value) + (setenv variable value))) + variables)) + thunk + (lambda () + (environ environment))))) + +(define-syntax-rule (with-environment-variables variables exp ...) + "Evaluate EXP with the given environment VARIABLES set." + (call-with-environment-variables variables + (lambda () exp ...))) + (define (populate-git-repository directory directives) "Initialize a new Git checkout and repository in DIRECTORY and apply DIRECTIVES. Each element of DIRECTIVES is an sexp like: @@ -41,8 +59,21 @@ Return DIRECTORY on success." ;; Note: As of version 0.2.0, Guile-Git lacks the necessary bindings to do ;; all this, so resort to the "git" command. (define (git command . args) - (apply invoke (git-command) "-C" directory - command args)) + ;; Make sure Git doesn't rely on the user's config. + (call-with-temporary-directory + (lambda (home) + (call-with-output-file (string-append home "/.gitconfig") + (lambda (port) + (display "[user] + email = charlie@example.org\n name = Charlie Guix\n" + port))) + + (with-environment-variables + `(("GIT_CONFIG_NOSYSTEM" "1") + ("GIT_ATTR_NOSYSTEM" "1") + ("HOME" ,home)) + (apply invoke (git-command) "-C" directory + command args))))) (mkdir-p directory) (git "init") -- cgit v1.2.3