From 1d84d7bf6052c0c80bd212d4524876576e9817d4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 15 Feb 2018 16:13:36 +0100 Subject: build: Require Guile >= 2.0.13. * README, configure.ac, doc/guix.texi (Requirements): Increase minimum Guile version from 2.0.9 to 2.0.13. * config-daemon.ac: Remove use of 'GUIX_CHECK_UNBUFFERED_CBIP'. * m4/guix.m4 (GUIX_CHECK_UNBUFFERED_CBIP): Remove. * guix/build/download.scm (current-http-proxy): Remove. * guix/build/syscalls.scm (%libc-errno-pointer, errno): Remove. (syscall->procedure): Use #:return-errno unconditionally. * guix/hash.scm (open-sha256-input-port)[unbuffered]: Remove outdated comment. * guix/http-client.scm (when-guile<=2.0.5-or-otherwise-broken): Remove. : Remove 'when-guile<=2.0.5-or-otherwise-broken' block. * guix/scripts/substitute.scm (fetch): Remove 'guile-version>?' conditional. * tests/hash.scm (supports-unbuffered-cbip?): Remove. : Remove 'test-skip' call. --- guix/build/download.scm | 10 +-- guix/build/syscalls.scm | 48 +------------- guix/hash.scm | 3 +- guix/http-client.scm | 154 +------------------------------------------- guix/scripts/substitute.scm | 18 ++---- 5 files changed, 10 insertions(+), 223 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 1b630a9d6d..315a3554ec 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; @@ -321,14 +321,6 @@ host name without trailing dot." ((uri? uri-or-string) uri-or-string) (else (error "Invalid URI" uri-or-string)))) -(define current-http-proxy - ;; XXX: Add a dummy definition for Guile < 2.0.10; this is used in - ;; 'open-socket-for-uri'. - (or (and=> (module-variable (resolve-interface '(web client)) - 'current-http-proxy) - variable-ref) - (const #f))) - (define* (open-socket-for-uri uri-or-string #:key timeout) "Return an open input/output port for a connection to URI. When TIMEOUT is not #f, it must be a (possibly inexact) number denoting the maximum duration diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 0cb630cfb3..25726b885e 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Mathieu Othacehe @@ -350,39 +350,6 @@ expansion-time error is raised if FIELD does not exist in TYPE." ;;; FFI. ;;; -(define %libc-errno-pointer - ;; Glibc's 'errno' pointer, for use with Guile < 2.0.12. - (let ((errno-loc (false-if-exception - (dynamic-func "__errno_location" (dynamic-link))))) - (and errno-loc - (let ((proc (pointer->procedure '* errno-loc '()))) - (proc))))) - -(define errno ;for Guile < 2.0.12 - (if %libc-errno-pointer - (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) - (lambda () - "Return the current errno." - ;; XXX: We assume that nothing changes 'errno' while we're doing all this. - ;; In particular, that means that no async must be running here. - - ;; Use one of the fixed-size native-ref procedures because they are - ;; optimized down to a single VM instruction, which reduces the risk - ;; that we fiddle with 'errno' (needed on Guile 2.0.5, libc 2.11.) - (let-syntax ((ref (lambda (s) - (syntax-case s () - ((_ bv) - (case (sizeof int) - ((4) - #'(bytevector-s32-native-ref bv 0)) - ((8) - #'(bytevector-s64-native-ref bv 0)) - (else - (error "unsupported 'int' size" - (sizeof int))))))))) - (ref bv)))) - (lambda () 0))) - (define (call-with-restart-on-EINTR thunk) (let loop () (catch 'system-error @@ -406,17 +373,8 @@ the returned procedure is called." (lambda () (let ((ptr (dynamic-func name (dynamic-link)))) ;; The #:return-errno? facility was introduced in Guile 2.0.12. - ;; Support older versions of Guile by catching 'wrong-number-of-args'. - (catch 'wrong-number-of-args - (lambda () - (pointer->procedure return-type ptr argument-types - #:return-errno? #t)) - (lambda (key . rest) - (let ((proc (pointer->procedure return-type ptr argument-types))) - (lambda args - (let ((result (apply proc args)) - (err (errno))) - (values result err)))))))) + (pointer->procedure return-type ptr argument-types + #:return-errno? #t))) (lambda args (lambda _ (error (format #f "~a: syscall->procedure failed: ~s" diff --git a/guix/hash.scm b/guix/hash.scm index 44e4472580..773b9d4777 100644 --- a/guix/hash.scm +++ b/guix/hash.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -159,7 +159,6 @@ data read from PORT. The thunk always returns the same value." (define (unbuffered port) ;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports. - ;; If you get a wrong-type-arg error here, the fix is to upgrade Guile. :-) (setvbuf port _IONBF) port) diff --git a/guix/http-client.scm b/guix/http-client.scm index bab31875d1..e8a2a23fc5 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; Copyright © 2017 Tobias Geerinckx-Rice @@ -69,158 +69,6 @@ (reason http-get-error-reason)) ; string -(define-syntax when-guile<=2.0.5-or-otherwise-broken - (lambda (s) - (syntax-case s () - ((_ body ...) - ;; Always emit BODY, regardless of VERSION, because sometimes this code - ;; might be compiled with a recent Guile and run with 2.0.5---e.g., - ;; when using "guix pull". - #'(begin body ...))))) - -(when-guile<=2.0.5-or-otherwise-broken - ;; Backport of Guile commits 312e79f8 ("Add HTTP Chunked Encoding support to - ;; web modules."), 00d3ecf2 ("http: Do not buffer HTTP chunks."), and 53b8d5f - ;; ("web: Gracefully handle premature EOF when reading chunk header.") - - (use-modules (ice-9 rdelim)) - - (define %web-http - (resolve-module '(web http))) - - ;; Chunked Responses - (define (read-chunk-header port) - "Read a chunk header from PORT and return the size in bytes of the - upcoming chunk." - (match (read-line port) - ((? eof-object?) - ;; Connection closed prematurely: there's nothing left to read. - 0) - (str - (let ((extension-start (string-index str - (lambda (c) - (or (char=? c #\;) - (char=? c #\return)))))) - (string->number (if extension-start ; unnecessary? - (substring str 0 extension-start) - str) - 16))))) - - (define* (make-chunked-input-port port #:key (keep-alive? #f)) - "Returns a new port which translates HTTP chunked transfer encoded -data from PORT into a non-encoded format. Returns eof when it has -read the final chunk from PORT. This does not necessarily mean -that there is no more data on PORT. When the returned port is -closed it will also close PORT, unless the KEEP-ALIVE? is true." - (define (close) - (unless keep-alive? - (close-port port))) - - (define chunk-size 0) ;size of the current chunk - (define remaining 0) ;number of bytes left from the current chunk - (define finished? #f) ;did we get all the chunks? - - (define (read! bv idx to-read) - (define (loop to-read num-read) - (cond ((or finished? (zero? to-read)) - num-read) - ((zero? remaining) ;get a new chunk - (let ((size (read-chunk-header port))) - (set! chunk-size size) - (set! remaining size) - (if (zero? size) - (begin - (set! finished? #t) - num-read) - (loop to-read num-read)))) - (else ;read from the current chunk - (let* ((ask-for (min to-read remaining)) - (read (get-bytevector-n! port bv (+ idx num-read) - ask-for))) - (if (eof-object? read) - (begin ;premature termination - (set! finished? #t) - num-read) - (let ((left (- remaining read))) - (set! remaining left) - (when (zero? left) - ;; We're done with this chunk; read CR and LF. - (get-u8 port) (get-u8 port)) - (loop (- to-read read) - (+ num-read read)))))))) - (loop to-read 0)) - - (make-custom-binary-input-port "chunked input port" read! #f #f close)) - - ;; Chunked encoding support in Guile <= 2.0.11 would load whole chunks in - ;; memory---see . - (when (module-variable %web-http 'read-chunk-body) - (module-set! %web-http 'make-chunked-input-port make-chunked-input-port)) - - (define (make-delimited-input-port port len keep-alive?) - "Return an input port that reads from PORT, and makes sure that -exactly LEN bytes are available from PORT. Closing the returned port -closes PORT, unless KEEP-ALIVE? is true." - (define bytes-read 0) - - (define (fail) - ((@@ (web response) bad-response) - "EOF while reading response body: ~a bytes of ~a" - bytes-read len)) - - (define (read! bv start count) - ;; Read at most LEN bytes in total. HTTP/1.1 doesn't say what to do - ;; when a server provides more than the Content-Length, but it seems - ;; wise to just stop reading at LEN. - (let ((count (min count (- len bytes-read)))) - (let loop ((ret (get-bytevector-n! port bv start count))) - (cond ((eof-object? ret) - (if (= bytes-read len) - 0 ; EOF - (fail))) - ((and (zero? ret) (> count 0)) - ;; Do not return zero since zero means EOF, so try again. - (loop (get-bytevector-n! port bv start count))) - (else - (set! bytes-read (+ bytes-read ret)) - ret))))) - - (define close - (and (not keep-alive?) - (lambda () - (close-port port)))) - - (make-custom-binary-input-port "delimited input port" read! #f #f close)) - - (define (read-header-line port) - "Read an HTTP header line and return it without its final CRLF or LF. -Raise a 'bad-header' exception if the line does not end in CRLF or LF, -or if EOF is reached." - (match (%read-line port) - (((? string? line) . #\newline) - ;; '%read-line' does not consider #\return a delimiter; so if it's - ;; there, remove it. We are more tolerant than the RFC in that we - ;; tolerate LF-only endings. - (if (string-suffix? "\r" line) - (string-drop-right line 1) - line)) - ((line . _) ;EOF or missing delimiter - ((@@ (web http) bad-header) 'read-header-line line)))) - - (unless (guile-version>? "2.0.11") - ;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more - ;; than what 'content-length' says. See Guile commit 802a25b. - ;; Guile <= 2.0.11 had a bug whereby the 'close' method of the response - ;; body port would fail with wrong-arg-num. See Guile commit 5a10e41. - (module-set! (resolve-module '(web response)) - 'make-delimited-input-port make-delimited-input-port) - - ;; Guile <= 2.0.11 was affected by . See Guile - ;; commit 4c7732c. - (when (module-variable %web-http 'read-line*) - (module-set! %web-http 'read-line* read-header-line)))) - - (define* (http-fetch uri #:key port (text? #f) (buffered? #t) keep-alive? (verify-certificate? #t) (headers '((user-agent . "GNU Guile")))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 2fd2bf8104..8e1119fb49 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2014 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -212,15 +212,7 @@ provide." (begin (warning (G_ "while fetching ~a: server is somewhat slow~%") (uri->string uri)) - (warning (G_ "try `--no-substitutes' if the problem persists~%")) - - ;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user, - ;; and thus PORT had to be closed and re-opened. This is not the - ;; case afterward. - (unless (or (guile-version>? "2.0.9") - (version>? (version) "2.0.9.39")) - (when port - (close-connection port)))) + (warning (G_ "try `--no-substitutes' if the problem persists~%"))) (begin (when (or (not port) (port-closed? port)) (set! port (guix:open-connection-for-uri @@ -571,10 +563,8 @@ initial connection on which HTTP requests are sent." ;; XXX: Do our own caching to work around inefficiencies when ;; communicating over TLS: . (let-values (((buffer get) (open-bytevector-output-port))) - ;; On Guile > 2.0.9, inherit the HTTP proxying property from P. - (when (module-variable (resolve-interface '(web http)) - 'http-proxy-port?) - (set-http-proxy-port?! buffer (http-proxy-port? p))) + ;; Inherit the HTTP proxying property from P. + (set-http-proxy-port?! buffer (http-proxy-port? p)) (for-each (cut write-request <> buffer) (at-most 1000 requests)) -- cgit v1.2.3 From 0fb405796cdb5579c911b30da9d40b4a18cd7f07 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Feb 2018 15:46:56 +0100 Subject: guix package: '--search' no longer shows superseded packages. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Björn Höfling . * guix/scripts/package.scm (find-packages-by-description): Ignore superseded packages. * tests/guix-package.sh: Add test. --- guix/scripts/package.scm | 16 ++++++++++------ tests/guix-package.sh | 18 +++++++++++++++++- 2 files changed, 27 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 617e102d93..d8b80efe8e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2013, 2015 Mark H Weaver ;;; Copyright © 2014, 2016 Alex Kost @@ -247,11 +247,15 @@ specified in MANIFEST, a manifest object." description matches at least one of REGEXPS sorted by relevance, and the list of relevance scores." (let ((matches (fold-packages (lambda (package result) - (match (package-relevance package regexps) - ((? zero?) - result) - (score - (cons (list package score) result)))) + (if (package-superseded package) + result + (match (package-relevance package + regexps) + ((? zero?) + result) + (score + (cons (list package score) + result))))) '()))) (unzip2 (sort matches (lambda (m1 m2) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index ffc8c64e24..760a2e4c9b 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès # Copyright © 2013 Nikita Karetnikov # # This file is part of GNU Guix. @@ -118,6 +118,22 @@ grep '^name: gnubg' "$tmpfile" rm -f "$tmpfile" +# Make sure deprecated packages don't show up: . +mkdir "$module_dir" +cat > "$module_dir/foo.scm"< /dev/null -- cgit v1.2.3 From 297602513bf023e485a496bbb813cb9cafdf7475 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Feb 2018 16:42:34 +0100 Subject: build-system/trivial: Add support for #:allowed-references. * guix/build-system/trivial.scm (lower): Add #:allowed-references and keep it in the 'arguments' field. (trivial-build): Add #:allowed-references. Add 'canonicalize-reference'. Pass #:allowed-references to 'build-expression->derivation'. (trivial-cross-build): Likewise. * tests/packages.scm ("trivial with #:allowed-references"): New test. --- guix/build-system/trivial.scm | 42 +++++++++++++++++++++++++++++++++++++----- tests/packages.scm | 20 +++++++++++++++++++- 2 files changed, 56 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index 350b1df553..b50ef7cd92 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,7 +36,7 @@ (define* (lower name #:key source inputs native-inputs outputs system target - guile builder modules) + guile builder modules allowed-references) "Return a bag for NAME." (bag (name name) @@ -51,19 +51,36 @@ (build (if target trivial-cross-build trivial-build)) (arguments `(#:guile ,guile #:builder ,builder - #:modules ,modules)))) + #:modules ,modules + #:allowed-references ,allowed-references)))) (define* (trivial-build store name inputs #:key outputs guile system builder (modules '()) - search-paths) + search-paths allowed-references) "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is ignored." + (define canonicalize-reference + (match-lambda + ((? package? p) + (derivation->output-path (package-derivation store p system + #:graft? #f))) + (((? package? p) output) + (derivation->output-path (package-derivation store p system + #:graft? #f) + output)) + ((? string? output) + output))) + (build-expression->derivation store name builder #:inputs inputs #:system system #:outputs outputs #:modules modules + #:allowed-references + (and allowed-references + (map canonicalize-reference + allowed-references)) #:guile-for-build (guile-for-build store guile system))) @@ -71,14 +88,29 @@ ignored." #:key target native-drvs target-drvs outputs guile system builder (modules '()) - search-paths native-search-paths) + search-paths native-search-paths + allowed-references) "Run build expression BUILDER, an expression, for SYSTEM. SOURCE is ignored." + (define canonicalize-reference + (match-lambda + ((? package? p) + (derivation->output-path (package-cross-derivation store p system))) + (((? package? p) output) + (derivation->output-path (package-cross-derivation store p system) + output)) + ((? string? output) + output))) + (build-expression->derivation store name builder #:inputs (append native-drvs target-drvs) #:system system #:outputs outputs #:modules modules + #:allowed-references + (and allowed-references + (map canonicalize-reference + allowed-references)) #:guile-for-build (guile-for-build store guile system))) diff --git a/tests/packages.scm b/tests/packages.scm index 930374dabf..b2fa21a874 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -557,6 +557,24 @@ (let ((p (pk 'drv d (derivation->output-path d)))) (eq? 'hello (call-with-input-file p read)))))) +(test-assert "trivial with #:allowed-references" + (let* ((p (package + (inherit (dummy-package "trivial")) + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:allowed-references (,%bootstrap-guile) + #:builder + (begin + (mkdir %output) + ;; The reference to itself isn't allowed so building it + ;; should fail. + (symlink %output (string-append %output "/self"))))))) + (d (package-derivation %store p))) + (guard (c ((nix-protocol-error? c) #t)) + (build-derivations %store (list d)) + #f))) + (test-assert "search paths" (let* ((p (make-prompt-tag "return-search-paths")) (s (build-system -- cgit v1.2.3 From 435603a1d6106b535cf143d17cb030b2d0795b54 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Mar 2018 11:37:36 +0100 Subject: profiles: 'manifest-add' truly deletes duplicate entries. Fixes . Reported by Andreas Enge . * guix/profiles.scm (manifest-add): Don't append ENTRIES as is. Instead, cons each element of ENTRIES as we fold over it. Remove unneeded ellispes in 'match' patterns. --- guix/profiles.scm | 20 ++++++++++---------- tests/profiles.scm | 7 ++++++- 2 files changed, 16 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 8e3e49e444..95dc9746bd 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver @@ -494,19 +494,19 @@ must be a manifest-pattern." Remove MANIFEST entries that have the same name and output as ENTRIES." (define (same-entry? entry name output) (match entry - (($ entry-name _ entry-output _ ...) + (($ entry-name _ entry-output _) (and (equal? name entry-name) (equal? output entry-output))))) (make-manifest - (append entries - (fold (lambda (entry result) - (match entry - (($ name _ out _ ...) - (filter (negate (cut same-entry? <> name out)) - result)))) - (manifest-entries manifest) - entries)))) + (fold (lambda (entry result) ;XXX: quadratic + (match entry + (($ name _ out _) + (cons entry + (remove (cut same-entry? <> name out) + result))))) + (manifest-entries manifest) + entries))) (define (manifest-lookup manifest pattern) "Return the first item of MANIFEST that matches PATTERN, or #f if there is diff --git a/tests/profiles.scm b/tests/profiles.scm index 469dde2652..92eb08cb9e 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2014 Alex Kost ;;; ;;; This file is part of GNU Guix. @@ -148,6 +148,11 @@ (_ #f)) (equal? m3 m4)))) +(test-equal "manifest-add removes duplicates" ; + (list guile-2.0.9) + (manifest-entries (manifest-add (manifest '()) + (list guile-2.0.9 guile-2.0.9)))) + (test-assert "manifest-perform-transaction" (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug))) (t1 (manifest-transaction -- cgit v1.2.3 From b402f4ee34d35f9b934b5449d2cc419dc287895e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Mar 2018 14:54:55 +0100 Subject: import: cpan: Drop "v" prefix from version strings. Fixes . Reported by Oleg Pykhalov . * guix/import/cpan.scm (cpan-version): Drop the "v" prefix when it is there. --- guix/import/cpan.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 2ef02c43a4..58c051e283 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -131,7 +131,11 @@ or #f on failure. MODULE should be e.g. \"Test::Script\"" ;; version is sometimes not quoted in the module json, so it gets ;; imported into Guile as a number, so convert it to a string. (number->string version)) - (version version))) + (version + ;; Sometimes we get a "v" prefix. Strip it. + (if (string-prefix? "v" version) + (string-drop version 1) + version)))) (define (perl-package) "Return the 'perl' package. This is a lazy reference so that we don't -- cgit v1.2.3 From 07ec349229eeae9f733fe92a300c7cfa4cf8e321 Mon Sep 17 00:00:00 2001 From: Mike Gerwitz Date: Thu, 25 Jan 2018 22:29:15 -0500 Subject: environment: Add --link-profile. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This change is motivated by attempts to run programs (like GNU IceCat) within containers. The 'fontconfig' program, for example, is configured explicitly to check ~/.guix-profile for additional fonts. There were no existing container tests in 'tests/guix-environment.sh', but I added one anyway for this change. * doc/guix.texi (Invoking guix environment): Add '--link-profile'. * guix/scripts/environment.scm (show-help): Add '--link-profile'. (%options): Add 'link-profile' as '#\P', assigned to 'link-profile?'. (link-environment): New procedure. (launch-environment/container): Use it when 'link-profile?'. [link-profile?]: New parameter. (guix-environment): Leave when '--link-prof' but not '--container'. Add '#:link-profile?' argument to 'launch-environment/container' application. * tests/guix-environment-container.sh: New '--link-profile' test. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 21 ++++++++++++++++-- guix/scripts/environment.scm | 43 +++++++++++++++++++++++++++++++------ tests/guix-environment-container.sh | 14 ++++++++++++ 3 files changed, 70 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 24db167618..826f924d22 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -46,7 +46,8 @@ Copyright @copyright{} 2017 Andy Wingo@* Copyright @copyright{} 2017, 2018 Arun Isaac@* Copyright @copyright{} 2017 nee@* Copyright @copyright{} 2018 Rutger Helling@* -Copyright @copyright{} 2018 Oleg Pykhalov +Copyright @copyright{} 2018 Oleg Pykhalov@* +Copyright @copyright{} 2018 Mike Gerwitz Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -1572,7 +1573,7 @@ To be able to use such full names for the TrueType fonts installed in your Guix profile, you need to extend the font path of the X server: @example -xset +fp ~/.guix-profile/share/fonts/truetype +xset +fp `readlink -f ~/.guix-profile/share/fonts/truetype` @end example @cindex @code{xlsfonts} @@ -7296,6 +7297,22 @@ For containers, share the network namespace with the host system. Containers created without this flag only have access to the loopback device. +@item --link-profile +@itemx -P +For containers, link the environment profile to +@file{~/.guix-profile} within the container. This is equivalent to +running the command @command{ln -s $GUIX_ENVIRONMENT ~/.guix-profile} +within the container. Linking will fail and abort the environment if +the directory already exists, which will certainly be the case if +@command{guix environment} was invoked in the user's home directory. + +Certain packages are configured to look in +@code{~/.guix-profile} for configuration files and data;@footnote{For +example, the @code{fontconfig} package inspects +@file{~/.guix-profile/share/fonts} for additional fonts.} +@code{--link-profile} allows these programs to behave as expected within +the environment. + @item --expose=@var{source}[=@var{target}] For containers, expose the file system @var{source} from the host system as the read-only file system @var{target} within the container. If diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 67da6fc3bf..5c7d83881c 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2018 Mike Gerwitz ;;; ;;; This file is part of GNU Guix. ;;; @@ -159,6 +160,9 @@ COMMAND or an interactive shell in that environment.\n")) -C, --container run command within an isolated container")) (display (G_ " -N, --network allow containers to access the network")) + (display (G_ " + -P, --link-profile link environment profile to ~/.guix-profile within + an isolated container")) (display (G_ " --share=SPEC for containers, share writable host file system according to SPEC")) @@ -243,6 +247,9 @@ COMMAND or an interactive shell in that environment.\n")) (option '(#\N "network") #f #f (lambda (opt name arg result) (alist-cons 'network? #t result))) + (option '(#\P "link-profile") #f #f + (lambda (opt name arg result) + (alist-cons 'link-profile? #t result))) (option '("share") #t #f (lambda (opt name arg result) (alist-cons 'file-system-mapping @@ -404,18 +411,20 @@ environment variables are cleared before setting the new ones." ((_ . status) status))))) (define* (launch-environment/container #:key command bash user-mappings - profile paths network?) + profile paths link-profile? network?) "Run COMMAND within a container that features the software in PROFILE. Environment variables are set according to PATHS, a list of native search paths. The global shell is BASH, a file name for a GNU Bash binary in the store. When NETWORK?, access to the host system network is permitted. USER-MAPPINGS, a list of file system mappings, contains the user-specified -host file systems to mount inside the container." +host file systems to mount inside the container. LINK-PROFILE? creates a +symbolic link from ~/.guix-profile to the environment profile." (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return - (let* ((cwd (getcwd)) - (passwd (getpwuid (getuid))) + (let* ((cwd (getcwd)) + (passwd (getpwuid (getuid))) + (home-dir (passwd:dir passwd)) ;; Bind-mount all requisite store items, user-specified mappings, ;; /bin/sh, the current working directory, and possibly networking ;; configuration files within the container. @@ -460,8 +469,13 @@ host file systems to mount inside the container." ;; Create a dummy home directory under the same name as on the ;; host. - (mkdir-p (passwd:dir passwd)) - (setenv "HOME" (passwd:dir passwd)) + (mkdir-p home-dir) + (setenv "HOME" home-dir) + + ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile; + ;; this allows programs expecting that path to continue working as + ;; expected within a container. + (when link-profile? (link-environment profile home-dir)) ;; Create a dummy /etc/passwd to satisfy applications that demand ;; to read it, such as 'git clone' over SSH, a valid use-case when @@ -491,6 +505,18 @@ host file systems to mount inside the container." (delq 'net %namespaces) ; share host network %namespaces))))))) +(define (link-environment profile home-dir) + "Create a symbolic link from HOME-DIR/.guix-profile to PROFILE." + (let ((profile-dir (string-append home-dir "/.guix-profile"))) + (catch 'system-error + (lambda () + (symlink profile profile-dir)) + (lambda args + (if (= EEXIST (system-error-errno args)) + (leave (G_ "cannot link profile: '~a' already exists within container~%") + profile-dir) + (apply throw args)))))) + (define (environment-bash container? bootstrap? system) "Return a monadic value in the store monad for the version of GNU Bash needed in the environment for SYSTEM, if any. If CONTAINER? is #f, return #f. @@ -564,6 +590,7 @@ message if any test fails." (let* ((opts (parse-args args)) (pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?)) + (link-prof? (assoc-ref opts 'link-profile?)) (network? (assoc-ref opts 'network?)) (bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system)) @@ -597,6 +624,9 @@ message if any test fails." (when container? (assert-container-features)) + (when (and (not container?) link-prof?) + (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) + (with-store store (set-build-options-from-command-line store opts) @@ -646,6 +676,7 @@ message if any test fails." #:user-mappings mappings #:profile profile #:paths paths + #:link-profile? link-prof? #:network? network?))) (else (return diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index d7c1b7057e..df40ce03e0 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -97,6 +97,20 @@ grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash rm $tmpdir/mounts +# Make sure 'GUIX_ENVIRONMENT' is linked to '~/.guix-profile' when requested +# within a container. +( + linktest='(exit (string=? (getenv "GUIX_ENVIRONMENT") +(readlink (string-append (getenv "HOME") "/.guix-profile"))))' + + cd "$tmpdir" \ + && guix environment --bootstrap --container --link-profile \ + --ad-hoc guile-bootstrap --pure \ + -- guile -c "$linktest" +) + +# Check the exit code. + abnormal_exit_code=" (use-modules (system foreign)) ;; Purposely make Guile crash with a segfault. :) -- cgit v1.2.3 From e37944d8270cdca5729e3583136c4fe9d487779c Mon Sep 17 00:00:00 2001 From: Mike Gerwitz Date: Thu, 25 Jan 2018 22:29:32 -0500 Subject: environment: Add --user. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This change allows overriding the home directory of all filesystem mappings to help hide the identity of the calling user in a container. * doc/guix.texi (Invoking guix environment)[--container]: Mention --user. [--user]: Add item. * guix/scripts/environment.scm (show-help): Add --user. (%options): Add --user. (launch-environment/container) Add 'user' parameter. Update doc. Override 'user-mappings' using 'override-user-mappings'. Consider override for chdir. (mock-passwd, user-override-home, overrid-euser-dir): New procedures. (guix-environment): Disallow --user without --container. Provide user to 'launch-environment/container'. * tests/guix-environment.sh: Add user test. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 34 ++++++++-- guix/scripts/environment.scm | 122 ++++++++++++++++++++++++++++-------- tests/guix-environment-container.sh | 11 ++++ 3 files changed, 138 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 826f924d22..d35ce0e26b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7286,10 +7286,11 @@ Attempt to build for @var{system}---e.g., @code{i686-linux}. @cindex container Run @var{command} within an isolated container. The current working directory outside the container is mapped inside the container. -Additionally, a dummy home directory is created that matches the current -user's home directory, and @file{/etc/passwd} is configured accordingly. -The spawned process runs as the current user outside the container, but -has root privileges in the context of the container. +Additionally, unless overridden with @code{--user}, a dummy home +directory is created that matches the current user's home directory, and +@file{/etc/passwd} is configured accordingly. The spawned process runs +as the current user outside the container, but has root privileges in +the context of the container. @item --network @itemx -N @@ -7313,6 +7314,31 @@ example, the @code{fontconfig} package inspects @code{--link-profile} allows these programs to behave as expected within the environment. +@item --user=@var{user} +@itemx -u @var{user} +For containers, use the username @var{user} in place of the current +user. The generated @file{/etc/passwd} entry within the container will +contain the name @var{user}; the home directory will be +@file{/home/USER}; and no user GECOS data will be copied. @var{user} +need not exist on the system. + +Additionally, any shared or exposed path (see @code{--share} and +@code{--expose} respectively) whose target is within the current user's +home directory will be remapped relative to @file{/home/USER}; this +includes the automatic mapping of the current working directory. + +@example +# will expose paths as /home/foo/wd, /home/foo/test, and /home/foo/target +cd $HOME/wd +guix environment --container --user=foo \ + --expose=$HOME/test \ + --expose=/tmp/target=$HOME/target +@end example + +While this will limit the leaking of user identity through home paths +and each of the user fields, this is only one useful component of a +broader privacy/anonymity solution---not one in and of itself. + @item --expose=@var{source}[=@var{target}] For containers, expose the file system @var{source} from the host system as the read-only file system @var{target} within the container. If diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 5c7d83881c..4f88c513c0 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -163,6 +163,10 @@ COMMAND or an interactive shell in that environment.\n")) (display (G_ " -P, --link-profile link environment profile to ~/.guix-profile within an isolated container")) + (display (G_ " + -u, --user=USER instead of copying the name and home of the current + user into an isolated container, use the name USER + with home directory /home/USER")) (display (G_ " --share=SPEC for containers, share writable host file system according to SPEC")) @@ -250,6 +254,10 @@ COMMAND or an interactive shell in that environment.\n")) (option '(#\P "link-profile") #f #f (lambda (opt name arg result) (alist-cons 'link-profile? #t result))) + (option '(#\u "user") #t #f + (lambda (opt name arg result) + (alist-cons 'user arg + (alist-delete 'user result eq?)))) (option '("share") #t #f (lambda (opt name arg result) (alist-cons 'file-system-mapping @@ -410,43 +418,50 @@ environment variables are cleared before setting the new ones." (pid (match (waitpid pid) ((_ . status) status))))) -(define* (launch-environment/container #:key command bash user-mappings +(define* (launch-environment/container #:key command bash user user-mappings profile paths link-profile? network?) "Run COMMAND within a container that features the software in PROFILE. Environment variables are set according to PATHS, a list of native search paths. The global shell is BASH, a file name for a GNU Bash binary in the store. When NETWORK?, access to the host system network is permitted. USER-MAPPINGS, a list of file system mappings, contains the user-specified -host file systems to mount inside the container. LINK-PROFILE? creates a -symbolic link from ~/.guix-profile to the environment profile." +host file systems to mount inside the container. If USER is not #f, each +target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER +will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from +~/.guix-profile to the environment profile." (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return (let* ((cwd (getcwd)) - (passwd (getpwuid (getuid))) + (home (getenv "HOME")) + (passwd (mock-passwd (getpwuid (getuid)) + user + bash)) (home-dir (passwd:dir passwd)) ;; Bind-mount all requisite store items, user-specified mappings, ;; /bin/sh, the current working directory, and possibly networking ;; configuration files within the container. (mappings - (append user-mappings - ;; Current working directory. - (list (file-system-mapping - (source cwd) - (target cwd) - (writable? #t))) - ;; When in Rome, do as Nix build.cc does: Automagically - ;; map common network configuration files. - (if network? - %network-file-mappings - '()) - ;; Mappings for the union closure of all inputs. - (map (lambda (dir) - (file-system-mapping - (source dir) - (target dir) - (writable? #f))) - reqs))) + (override-user-mappings + user home + (append user-mappings + ;; Current working directory. + (list (file-system-mapping + (source cwd) + (target cwd) + (writable? #t))) + ;; When in Rome, do as Nix build.cc does: Automagically + ;; map common network configuration files. + (if network? + %network-file-mappings + '()) + ;; Mappings for the union closure of all inputs. + (map (lambda (dir) + (file-system-mapping + (source dir) + (target dir) + (writable? #f))) + reqs)))) (file-systems (append %container-file-systems (map file-system-mapping->bind-mount mappings)))) @@ -467,8 +482,7 @@ symbolic link from ~/.guix-profile to the environment profile." ;; The same variables as in Nix's 'build.cc'. '("TMPDIR" "TEMPDIR" "TMP" "TEMP")) - ;; Create a dummy home directory under the same name as on the - ;; host. + ;; Create a dummy home directory. (mkdir-p home-dir) (setenv "HOME" home-dir) @@ -495,7 +509,7 @@ symbolic link from ~/.guix-profile to the environment profile." ;; For convenience, start in the user's current working ;; directory rather than the root directory. - (chdir cwd) + (chdir (override-user-dir user home cwd)) (primitive-exit/status ;; A container's environment is already purified, so no need to @@ -505,6 +519,60 @@ symbolic link from ~/.guix-profile to the environment profile." (delq 'net %namespaces) ; share host network %namespaces))))))) +(define (mock-passwd passwd user-override shell) + "Generate mock information for '/etc/passwd'. If USER-OVERRIDE is not '#f', +it is expected to be a string representing the mock username; it will produce +a user of that name, with a home directory of '/home/USER-OVERRIDE', and no +GECOS field. If USER-OVERRIDE is '#f', data will be inherited from PASSWD. +In either case, the shadow password and UID/GID are cleared, since the user +runs as root within the container. SHELL will always be used in place of the +shell in PASSWD. + +The resulting vector is suitable for use with Guile's POSIX user procedures. + +See passwd(5) for more information each of the fields." + (if user-override + (vector + user-override + "x" "0" "0" ;; no shadow, user is now root + "" ;; no personal information + (user-override-home user-override) + shell) + (vector + (passwd:name passwd) + "x" "0" "0" ;; no shadow, user is now root + (passwd:gecos passwd) + (passwd:dir passwd) + shell))) + +(define (user-override-home user) + "Return home directory for override user USER." + (string-append "/home/" user)) + +(define (override-user-mappings user home mappings) + "If a username USER is provided, rewrite each HOME prefix in file system +mappings MAPPINGS to a home directory determined by 'override-user-dir'; +otherwise, return MAPPINGS." + (if (not user) + mappings + (map (lambda (mapping) + (let ((target (file-system-mapping-target mapping))) + (if (string-prefix? home target) + (file-system-mapping + (source (file-system-mapping-source mapping)) + (target (override-user-dir user home target)) + (writable? (file-system-mapping-writable? mapping))) + mapping))) + mappings))) + +(define (override-user-dir user home dir) + "If username USER is provided, overwrite string prefix HOME in DIR with a +directory determined by 'user-override-home'; otherwise, return DIR." + (if (and user (string-prefix? home dir)) + (string-append (user-override-home user) + (substring dir (string-length home))) + dir)) + (define (link-environment profile home-dir) "Create a symbolic link from HOME-DIR/.guix-profile to PROFILE." (let ((profile-dir (string-append home-dir "/.guix-profile"))) @@ -592,6 +660,7 @@ message if any test fails." (container? (assoc-ref opts 'container?)) (link-prof? (assoc-ref opts 'link-profile?)) (network? (assoc-ref opts 'network?)) + (user (assoc-ref opts 'user)) (bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system)) (command (or (assoc-ref opts 'exec) @@ -626,6 +695,8 @@ message if any test fails." (when (and (not container?) link-prof?) (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) + (when (and (not container?) user) + (leave (G_ "'--user' cannot be used without '--container'~%"))) (with-store store (set-build-options-from-command-line store opts) @@ -673,6 +744,7 @@ message if any test fails." "/bin/sh")))) (launch-environment/container #:command command #:bash bash-binary + #:user user #:user-mappings mappings #:profile profile #:paths paths diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index df40ce03e0..a2da9a0773 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -109,6 +109,17 @@ rm $tmpdir/mounts -- guile -c "$linktest" ) +# Test that user can be mocked. +usertest='(exit (and (string=? (getenv "HOME") "/home/foognu") + (string=? (passwd:name (getpwuid 0)) "foognu") + (file-exists? "/home/foognu/umock")))' +touch "$tmpdir/umock" +HOME="$tmpdir" guix environment --bootstrap --container --user=foognu \ + --ad-hoc guile-bootstrap --pure \ + --share="$tmpdir/umock" \ + -- guile -c "$usertest" + + # Check the exit code. abnormal_exit_code=" -- cgit v1.2.3 From f14c933df16ee0faee6bff8004da4e5d3e1caf07 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 16 Feb 2018 18:31:46 +0100 Subject: Add (guix glob). * guix/glob.scm, tests/glob.scm: New files. * Makefile.am (MODULES): Add guix/glob.scm. (SCM_TESTS): Add tests/glob.scm. --- Makefile.am | 4 ++- guix/glob.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/glob.scm | 58 +++++++++++++++++++++++++++++++++++ 3 files changed, 158 insertions(+), 1 deletion(-) create mode 100644 guix/glob.scm create mode 100644 tests/glob.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index e2c940ca8d..6556799e6b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès # Copyright © 2013 Andreas Enge # Copyright © 2015, 2017 Alex Kost # Copyright © 2016, 2018 Mathieu Lirzin @@ -83,6 +83,7 @@ MODULES = \ guix/gnu-maintenance.scm \ guix/upstream.scm \ guix/licenses.scm \ + guix/glob.scm \ guix/git.scm \ guix/graph.scm \ guix/cache.scm \ @@ -314,6 +315,7 @@ SCM_TESTS = \ tests/substitute.scm \ tests/builders.scm \ tests/derivations.scm \ + tests/glob.scm \ tests/grafts.scm \ tests/ui.scm \ tests/records.scm \ diff --git a/guix/glob.scm b/guix/glob.scm new file mode 100644 index 0000000000..4fc5173ac0 --- /dev/null +++ b/guix/glob.scm @@ -0,0 +1,97 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix glob) + #:use-module (ice-9 match) + #:export (compile-glob-pattern + glob-match?)) + +;;; Commentary: +;;; +;;; This is a minimal implementation of "glob patterns" (info "(libc) +;;; Globbbing"). It is currently limited to simple patterns and does not +;;; support braces and square brackets, for instance. +;;; +;;; Code: + +(define (wildcard-indices str) + "Return the list of indices in STR where wildcards can be found." + (let loop ((index 0) + (result '())) + (if (= index (string-length str)) + (reverse result) + (loop (+ 1 index) + (case (string-ref str index) + ((#\? #\*) (cons index result)) + (else result)))))) + +(define (compile-glob-pattern str) + "Return an sexp that represents the compiled form of STR, a glob pattern +such as \"foo*\" or \"foo??bar\"." + (define flatten + (match-lambda + (((? string? str)) str) + (x x))) + + (let loop ((index 0) + (indices (wildcard-indices str)) + (result '())) + (match indices + (() + (flatten (cond ((zero? index) + (list str)) + ((= index (string-length str)) + (reverse result)) + (else + (reverse (cons (string-drop str index) + result)))))) + ((wildcard-index . rest) + (let ((wildcard (match (string-ref str wildcard-index) + (#\? '?) + (#\* '*)))) + (match (substring str index wildcard-index) + ("" (loop (+ 1 wildcard-index) + rest + (cons wildcard result))) + (str (loop (+ 1 wildcard-index) + rest + (cons* wildcard str result))))))))) + +(define (glob-match? pattern str) + "Return true if STR matches PATTERN, a compiled glob pattern as returned by +'compile-glob-pattern'." + (let loop ((pattern pattern) + (str str)) + (match pattern + ((? string? literal) (string=? literal str)) + (((? string? one)) (string=? one str)) + (('*) #t) + (('?) (= 1 (string-length str))) + (() #t) + (('* suffix . rest) + (match (string-contains str suffix) + (#f #f) + (index (loop rest + (string-drop str + (+ index (string-length suffix))))))) + (('? . rest) + (and (>= (string-length str) 1) + (loop rest (string-drop str 1)))) + ((prefix . rest) + (and (string-prefix? prefix str) + (loop rest (string-drop str (string-length prefix)))))))) diff --git a/tests/glob.scm b/tests/glob.scm new file mode 100644 index 0000000000..033eeb10fe --- /dev/null +++ b/tests/glob.scm @@ -0,0 +1,58 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-glob) + #:use-module (guix glob) + #:use-module (srfi srfi-64)) + + +(test-begin "glob") + +(test-equal "compile-glob-pattern, no wildcards" + "foo" + (compile-glob-pattern "foo")) + +(test-equal "compile-glob-pattern, Kleene star" + '("foo" * "bar") + (compile-glob-pattern "foo*bar")) + +(test-equal "compile-glob-pattern, question mark" + '(? "foo" *) + (compile-glob-pattern "?foo*")) + +(test-assert "literal match" + (let ((pattern (compile-glob-pattern "foo"))) + (and (glob-match? pattern "foo") + (not (glob-match? pattern "foobar")) + (not (glob-match? pattern "barfoo"))))) + +(test-assert "trailing star" + (let ((pattern (compile-glob-pattern "foo*"))) + (and (glob-match? pattern "foo") + (glob-match? pattern "foobar") + (not (glob-match? pattern "xfoo"))))) + +(test-assert "question marks" + (let ((pattern (compile-glob-pattern "foo??bar"))) + (and (glob-match? pattern "fooxxbar") + (glob-match? pattern "fooZZbar") + (not (glob-match? pattern "foobar")) + (not (glob-match? pattern "fooxxxbar")) + (not (glob-match? pattern "fooxxbarzz"))))) + +(test-end "glob") -- cgit v1.2.3 From 424cea8083a4cee63290c80235aed61bd12affb1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Feb 2018 14:55:43 +0100 Subject: guix system: Check for the lack of modules in the initrd. * guix/scripts/system.scm (check-mapped-devices): Take an OS instead of a list of . Pass #:needed-for-boot? and #:initrd-modules to CHECK. (check-initrd-modules): New procedure. (perform-action): Move 'check-mapped-devices' call first. Add call to 'check-initrd-modules'. * gnu/system/mapped-devices.scm (check-device-initrd-modules): New procedure. (check-luks-device): Add #:initrd-modules and #:needed-for-boot?. Use them to call 'check-device-initrd-modules'. --- gnu/system/mapped-devices.scm | 53 +++++++++++++++++++++++++--------- guix/scripts/system.scm | 67 ++++++++++++++++++++++++++++++++++++------- 2 files changed, 96 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index dbeb0d3436..5ceb5e658c 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2016 Andreas Enge ;;; Copyright © 2017 Mark H Weaver ;;; @@ -30,9 +30,12 @@ #:use-module (gnu services shepherd) #:use-module (gnu system uuid) #:autoload (gnu build file-systems) (find-partition-by-luks-uuid) + #:autoload (gnu build linux-modules) + (device-module-aliases matching-modules) #:autoload (gnu packages cryptsetup) (cryptsetup-static) #:autoload (gnu packages linux) (mdadm-static) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 match) @@ -151,19 +154,43 @@ #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") "close" #$target))) -(define (check-luks-device md) +(define (check-device-initrd-modules device linux-modules location) + "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate. +DEVICE must be a \"/dev\" file name." + (let ((modules (delete-duplicates + (append-map matching-modules + (device-module-aliases device))))) + (unless (every (cute member <> linux-modules) modules) + (raise (condition + (&message + (message (format #f (G_ "you may need these modules \ +in the initrd for ~a:~{ ~a~}") + device modules))) + (&error-location + (location (source-properties->location location)))))))) + +(define* (check-luks-device md #:key + needed-for-boot? + (initrd-modules '()) + #:allow-other-keys + #:rest rest) "Ensure the source of MD is valid." - (let ((source (mapped-device-source md))) - (or (not (uuid? source)) - (not (zero? (getuid))) - (find-partition-by-luks-uuid (uuid-bytevector source)) - (raise (condition - (&message - (message (format #f (G_ "no LUKS partition with UUID '~a'") - (uuid->string source)))) - (&error-location - (location (source-properties->location - (mapped-device-location md))))))))) + (let ((source (mapped-device-source md)) + (location (mapped-device-location md))) + (or (not (zero? (getuid))) + (if (uuid? source) + (match (find-partition-by-luks-uuid (uuid-bytevector source)) + (#f + (raise (condition + (&message + (message (format #f (G_ "no LUKS partition with UUID '~a'") + (uuid->string source)))) + (&error-location + (location (source-properties->location + (mapped-device-location md))))))) + ((? string? device) + (check-device-initrd-modules device initrd-modules location))) + (check-device-initrd-modules source initrd-modules location))))) (define luks-device-mapping ;; The type of LUKS mapped devices. diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 999ffb010b..ff322ec785 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -41,6 +41,10 @@ #:use-module (gnu build install) #:autoload (gnu build file-systems) (find-partition-by-label find-partition-by-uuid) + #:autoload (gnu build linux-modules) + (device-module-aliases matching-modules) + #:autoload (gnu system linux-initrd) + (base-initrd default-initrd-modules) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -624,21 +628,61 @@ any, are available. Raise an error if they're not." ;; Better be safe than sorry. (exit 1)))) -(define (check-mapped-devices mapped-devices) +(define (check-mapped-devices os) "Check that each of MAPPED-DEVICES is valid according to the 'check' procedure of its type." + (define boot-mapped-devices + (operating-system-boot-mapped-devices os)) + + (define (needed-for-boot? md) + (memq md boot-mapped-devices)) + + (define initrd-modules + (operating-system-initrd-modules os)) + (for-each (lambda (md) (let ((check (mapped-device-kind-check (mapped-device-type md)))) ;; We expect CHECK to raise an exception with a detailed - ;; '&message' if something goes wrong, but handle the case - ;; where it just returns #f. - (unless (check md) - (leave (G_ "~a: invalid '~a' mapped device~%") - (location->string - (source-properties->location - (mapped-device-location md))))))) - mapped-devices)) + ;; '&message' if something goes wrong. + (check md + #:needed-for-boot? (needed-for-boot? md) + #:initrd-modules initrd-modules))) + (operating-system-mapped-devices os))) + +(define (check-initrd-modules os) + "Check that modules needed by 'needed-for-boot' file systems in OS are +available in the initrd. Note that mapped devices are responsible for +checking this by themselves in their 'check' procedure." + (define (file-system-/dev fs) + (let ((device (file-system-device fs))) + (match (file-system-title fs) + ('device device) + ('uuid (find-partition-by-uuid device)) + ('label (find-partition-by-label device))))) + + (define (check-device device location) + (let ((modules (delete-duplicates + (append-map matching-modules + (device-module-aliases device))))) + (unless (every (cute member <> (operating-system-initrd-modules os)) + modules) + (raise (condition + (&message + (message (format #f (G_ "you need these modules \ +in the initrd for ~a:~{ ~a~}") + device modules))) + (&error-location (location location))))))) + + (define file-systems + (filter file-system-needed-for-boot? + (operating-system-file-systems os))) + + (for-each (lambda (fs) + (check-device (file-system-/dev fs) + (source-properties->location + (file-system-location fs)))) + file-systems)) ;;; @@ -730,9 +774,10 @@ output when building a system derivation, such as a disk image." ;; instantiating a broken configuration. Assume that we can only check if ;; running as root. (when (memq action '(init reconfigure)) + (check-mapped-devices os) (when (zero? (getuid)) - (check-file-system-availability (operating-system-file-systems os))) - (check-mapped-devices (operating-system-mapped-devices os))) + (check-file-system-availability (operating-system-file-systems os)) + (check-initrd-modules os))) (mlet* %store-monad ((sys (system-derivation-for-action os action -- cgit v1.2.3 From bdcf0e6fd484a54240a98ddf8b6fa433c1b9bd6c Mon Sep 17 00:00:00 2001 From: Clément Lassieur Date: Mon, 26 Feb 2018 01:12:24 +0100 Subject: services: messaging: Prosody config supports file-like objects. * doc/guix.texi (Messaging Services): Update accordingly. * gnu/services/configuration.scm (serialize-configuration, serialize-maybe-stem, serialize-package): Return strings or string-valued gexps (these procedures were only used for their side-effects). * gnu/services/messaging.scm (serialize-field, serialize-field-list, enclose-quotes, serialize-raw-content, serialize-ssl-configuration, serialize-virtualhost-configuration-list, serialize-int-component-configuration-list, serialize-ext-component-configuration-list, serialize-virtualhost-configuration, serialize-int-component-configuration, serialize-ext-component-configuration, serialize-prosody-configuration): Return strings or string-valued gexps and stop printing. (prosody-activation): Use SERIALIZE-PROSODY-CONFIGURATION's return value with MIXED-TEXT-FILE instead of using its output with PLAIN-FILE. (serialize-non-negative-integer, serialize-non-negative-integer-list): Convert numbers to strings. (file-object?, serialize-file-object, file-object-list?, serialize-file-object-list): New procedures. (ssl-configuration)[capath, cafile], (prosody-configuration)[plugin-paths, groups-file]: Replace FILE-NAME with FILE-OBJECT. * guix/gexp.scm (file-like?): New exported procedure. --- doc/guix.texi | 13 +++-- gnu/services/configuration.scm | 17 +++---- gnu/services/messaging.scm | 106 ++++++++++++++++++++++------------------- guix/gexp.scm | 7 +++ 4 files changed, 83 insertions(+), 60 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 50438f7cb4..057272df46 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -14258,6 +14258,9 @@ There is also a way to specify the configuration as a string, if you have an old @code{prosody.cfg.lua} file that you want to port over from some other system; see the end for more details. +The @code{file-object} type designates either a file-like object +(@pxref{G-Expressions, file-like objects}) or a file name. + @c The following documentation was initially generated by @c (generate-documentation) in (gnu services messaging). Manually maintained @c documentation is better, so we shouldn't hesitate to edit below as @@ -14278,7 +14281,7 @@ Location of the Prosody data storage directory. See Defaults to @samp{"/var/lib/prosody"}. @end deftypevr -@deftypevr {@code{prosody-configuration} parameter} file-name-list plugin-paths +@deftypevr {@code{prosody-configuration} parameter} file-object-list plugin-paths Additional plugin directories. They are searched in all the specified paths in order. See @url{https://prosody.im/doc/plugins_directory}. Defaults to @samp{()}. @@ -14319,7 +14322,7 @@ should you want to disable them then add them to this list. Defaults to @samp{()}. @end deftypevr -@deftypevr {@code{prosody-configuration} parameter} file-name groups-file +@deftypevr {@code{prosody-configuration} parameter} file-object groups-file Path to a text file where the shared groups are defined. If this path is empty then @samp{mod_groups} does nothing. See @url{https://prosody.im/doc/modules/mod_groups}. @@ -14352,13 +14355,13 @@ Path to your private key file. Path to your certificate file. @end deftypevr -@deftypevr {@code{ssl-configuration} parameter} file-name capath +@deftypevr {@code{ssl-configuration} parameter} file-object capath Path to directory containing root certificates that you wish Prosody to trust when verifying the certificates of remote servers. Defaults to @samp{"/etc/ssl/certs"}. @end deftypevr -@deftypevr {@code{ssl-configuration} parameter} maybe-file-name cafile +@deftypevr {@code{ssl-configuration} parameter} maybe-file-object cafile Path to a file containing root certificates that you wish Prosody to trust. Similar to @code{capath} but with all certificates concatenated together. @end deftypevr @@ -14618,6 +14621,8 @@ string, you could instantiate a prosody service like this: (prosody.cfg.lua ""))) @end example +@c end of Prosody auto-generated documentation + @subsubheading BitlBee Service @cindex IRC (Internet Relay Chat) diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index c45340f02f..707944cbe0 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Andy Wingo ;;; Copyright © 2017 Mathieu Othacehe -;;; Copyright © 2017 Clément Lassieur +;;; Copyright © 2017, 2018 Clément Lassieur ;;; ;;; This file is part of GNU Guix. ;;; @@ -74,11 +74,12 @@ (documentation configuration-field-documentation)) (define (serialize-configuration config fields) - (for-each (lambda (field) - ((configuration-field-serializer field) - (configuration-field-name field) - ((configuration-field-getter field) config))) - fields)) + #~(string-append + #$@(map (lambda (field) + ((configuration-field-serializer field) + (configuration-field-name field) + ((configuration-field-getter field) config))) + fields))) (define (validate-configuration config fields) (for-each (lambda (field) @@ -105,7 +106,7 @@ (define (maybe-stem? val) (or (eq? val 'disabled) (stem? val))) (define (serialize-maybe-stem field-name val) - (when (stem? val) (serialize-stem field-name val))))))))) + (if (stem? val) (serialize-stem field-name val) "")))))))) (define-syntax define-configuration (lambda (stx) @@ -147,7 +148,7 @@ conf)))))))) (define (serialize-package field-name val) - #f) + "") ;; A little helper to make it easier to document all those fields. (define (generate-documentation documentation documentation-name) diff --git a/gnu/services/messaging.scm b/gnu/services/messaging.scm index 427e2121f6..80ffed0f2f 100644 --- a/gnu/services/messaging.scm +++ b/gnu/services/messaging.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Clément Lassieur +;;; Copyright © 2017, 2018 Clément Lassieur ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2015, 2017, 2018 Ludovic Courtès ;;; @@ -115,16 +115,9 @@ "_"))) (define (serialize-field field-name val) - (format #t "~a = ~a;\n" (uglify-field-name field-name) val)) + #~(format #f "~a = ~a;\n" #$(uglify-field-name field-name) #$val)) (define (serialize-field-list field-name val) - (serialize-field field-name - (with-output-to-string - (lambda () - (format #t "{\n") - (for-each (lambda (x) - (format #t "~a;\n" x)) - val) - (format #t "}"))))) + (serialize-field field-name #~(format #f "{\n~@{~a;\n~}}" #$@val))) (define (serialize-boolean field-name val) (serialize-field field-name (if val "true" "false"))) @@ -140,17 +133,17 @@ (define (non-negative-integer? val) (and (exact-integer? val) (not (negative? val)))) (define (serialize-non-negative-integer field-name val) - (serialize-field field-name val)) + (serialize-field field-name (number->string val))) (define-maybe non-negative-integer) (define (non-negative-integer-list? val) (and (list? val) (and-map non-negative-integer? val))) (define (serialize-non-negative-integer-list field-name val) - (serialize-field-list field-name val)) + (serialize-field-list field-name (map number->string val))) (define-maybe non-negative-integer-list) (define (enclose-quotes s) - (format #f "\"~a\"" s)) + #~(string-append "\"" #$s "\"")) (define (serialize-string field-name val) (serialize-field field-name (enclose-quotes val))) (define-maybe string) @@ -183,10 +176,22 @@ (serialize-string-list field-name val)) (define-maybe file-name) +(define (file-object? val) + (or (file-like? val) (file-name? val))) +(define (serialize-file-object field-name val) + (serialize-string field-name val)) +(define-maybe file-object) + +(define (file-object-list? val) + (and (list? val) (and-map file-object? val))) +(define (serialize-file-object-list field-name val) + (serialize-string-list field-name val)) +(define-maybe file-object) + (define (raw-content? val) (not (eq? val 'disabled))) (define (serialize-raw-content field-name val) - (format #t "~a" val)) + val) (define-maybe raw-content) (define-configuration mod-muc-configuration @@ -224,12 +229,12 @@ just joined the room.")) "Path to your certificate file.") (capath - (file-name "/etc/ssl/certs") + (file-object "/etc/ssl/certs") "Path to directory containing root certificates that you wish Prosody to trust when verifying the certificates of remote servers.") (cafile - (maybe-file-name 'disabled) + (maybe-file-object 'disabled) "Path to a file containing root certificates that you wish Prosody to trust. Similar to @code{capath} but with all certificates concatenated together.") @@ -273,9 +278,8 @@ can create such a file with: (maybe-string 'disabled) "Password for encrypted private keys.")) (define (serialize-ssl-configuration field-name val) - (format #t "ssl = {\n") - (serialize-configuration val ssl-configuration-fields) - (format #t "};\n")) + #~(format #f "ssl = {\n~a};\n" + #$(serialize-configuration val ssl-configuration-fields))) (define-maybe ssl-configuration) (define %default-modules-enabled @@ -303,20 +307,23 @@ can create such a file with: (define (virtualhost-configuration-list? val) (and (list? val) (and-map virtualhost-configuration? val))) (define (serialize-virtualhost-configuration-list l) - (for-each - (lambda (val) (serialize-virtualhost-configuration val)) l)) + #~(string-append + #$@(map (lambda (val) + (serialize-virtualhost-configuration val)) l))) (define (int-component-configuration-list? val) (and (list? val) (and-map int-component-configuration? val))) (define (serialize-int-component-configuration-list l) - (for-each - (lambda (val) (serialize-int-component-configuration val)) l)) + #~(string-append + #$@(map (lambda (val) + (serialize-int-component-configuration val)) l))) (define (ext-component-configuration-list? val) (and (list? val) (and-map ext-component-configuration? val))) (define (serialize-ext-component-configuration-list l) - (for-each - (lambda (val) (serialize-ext-component-configuration val)) l)) + #~(string-append + #$@(map (lambda (val) + (serialize-ext-component-configuration val)) l))) (define-all-configurations prosody-configuration (prosody @@ -331,7 +338,7 @@ can create such a file with: global) (plugin-paths - (file-name-list '()) + (file-object-list '()) "Additional plugin directories. They are searched in all the specified paths in order. See @url{https://prosody.im/doc/plugins_directory}." global) @@ -372,7 +379,7 @@ should you want to disable them then add them to this list." common) (groups-file - (file-name "/var/lib/prosody/sharedgroups.txt") + (file-object "/var/lib/prosody/sharedgroups.txt") "Path to a text file where the shared groups are defined. If this path is empty then @samp{mod_groups} does nothing. See @url{https://prosody.im/doc/modules/mod_groups}." @@ -566,8 +573,9 @@ See also @url{https://prosody.im/doc/modules/mod_muc}." '(domain)))) (let ((domain (virtualhost-configuration-domain config)) (rest (filter rest? virtualhost-configuration-fields))) - (format #t "VirtualHost \"~a\"\n" domain) - (serialize-configuration config rest))) + #~(string-append + #$(format #f "VirtualHost \"~a\"\n" domain) + #$(serialize-configuration config rest)))) ;; Serialize Component line first. (define (serialize-int-component-configuration config) @@ -577,8 +585,9 @@ See also @url{https://prosody.im/doc/modules/mod_muc}." (let ((hostname (int-component-configuration-hostname config)) (plugin (int-component-configuration-plugin config)) (rest (filter rest? int-component-configuration-fields))) - (format #t "Component \"~a\" \"~a\"\n" hostname plugin) - (serialize-configuration config rest))) + #~(string-append + #$(format #f "Component \"~a\" \"~a\"\n" hostname plugin) + #$(serialize-configuration config rest)))) ;; Serialize Component line first. (define (serialize-ext-component-configuration config) @@ -587,22 +596,24 @@ See also @url{https://prosody.im/doc/modules/mod_muc}." '(hostname)))) (let ((hostname (ext-component-configuration-hostname config)) (rest (filter rest? ext-component-configuration-fields))) - (format #t "Component \"~a\"\n" hostname) - (serialize-configuration config rest))) + #~(string-append + #$(format #f "Component \"~a\"\n" hostname) + #$(serialize-configuration config rest)))) ;; Serialize virtualhosts and components last. (define (serialize-prosody-configuration config) (define (rest? field) (not (memq (configuration-field-name field) '(virtualhosts int-components ext-components)))) - (let ((rest (filter rest? prosody-configuration-fields))) - (serialize-configuration config rest)) - (serialize-virtualhost-configuration-list - (prosody-configuration-virtualhosts config)) - (serialize-int-component-configuration-list - (prosody-configuration-int-components config)) - (serialize-ext-component-configuration-list - (prosody-configuration-ext-components config))) + #~(string-append + #$(let ((rest (filter rest? prosody-configuration-fields))) + (serialize-configuration config rest)) + #$(serialize-virtualhost-configuration-list + (prosody-configuration-virtualhosts config)) + #$(serialize-int-component-configuration-list + (prosody-configuration-int-components config)) + #$(serialize-ext-component-configuration-list + (prosody-configuration-ext-components config)))) (define-configuration opaque-prosody-configuration (prosody @@ -646,13 +657,12 @@ See also @url{https://prosody.im/doc/modules/mod_muc}." (default-certs-dir "/etc/prosody/certs") (data-path (prosody-configuration-data-path config)) (pidfile-dir (dirname (prosody-configuration-pidfile config))) - (config-str - (if (opaque-prosody-configuration? config) - (opaque-prosody-configuration-prosody.cfg.lua config) - (with-output-to-string - (lambda () - (serialize-prosody-configuration config))))) - (config-file (plain-file "prosody.cfg.lua" config-str))) + (config-str (if (opaque-prosody-configuration? config) + (opaque-prosody-configuration-prosody.cfg.lua config) + #~(begin + (use-modules (ice-9 format)) + #$(serialize-prosody-configuration config)))) + (config-file (mixed-text-file "prosody.cfg.lua" config-str))) #~(begin (use-modules (guix build utils)) (define %user (getpw "prosody")) diff --git a/guix/gexp.scm b/guix/gexp.scm index f005c4d296..8dea022e04 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2018 Clément Lassieur ;;; ;;; This file is part of GNU Guix. ;;; @@ -86,6 +87,7 @@ define-gexp-compiler gexp-compiler? + file-like? lower-object lower-inputs @@ -182,6 +184,11 @@ procedure to lower it; otherwise return #f." (and=> (hashq-ref %gexp-compilers (struct-vtable object)) gexp-compiler-lower)) +(define (file-like? object) + "Return #t if OBJECT leads to a file in the store once unquoted in a +G-expression; otherwise return #f." + (and (struct? object) (->bool (lookup-compiler object)))) + (define (lookup-expander object) "Search for an expander for OBJECT. Upon success, return the three argument procedure to expand it; otherwise return #f." -- cgit v1.2.3 From 329dabe13bf98b899b907b45565434c5140804f5 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Wed, 14 Feb 2018 00:54:01 +0100 Subject: git-download: Fetch only the required commit, if possible. * guix/build/git.scm (git-fetch): Fetch only the required commit, if possible. --- guix/build/git.scm | 43 +++++++++++++++++++++++-------------------- 1 file changed, 23 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/build/git.scm b/guix/build/git.scm index c1af545a76..14d415a6f8 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -37,28 +37,31 @@ recursively. Return #t on success, #f otherwise." ;; in advance anyway. (setenv "GIT_SSL_NO_VERIFY" "true") - ;; We cannot use "git clone --recursive" since the following "git checkout" - ;; effectively removes sub-module checkouts as of Git 2.6.3. - (and (zero? (system* git-command "clone" url directory)) - (with-directory-excursion directory - (system* git-command "tag" "-l") - (and (zero? (system* git-command "checkout" commit)) - (begin - (when recursive? - ;; Now is the time to fetch sub-modules. - (unless (zero? (system* git-command "submodule" "update" + (mkdir-p directory) + + (with-directory-excursion directory + (invoke git-command "init") + (invoke git-command "remote" "add" "origin" url) + (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) + (invoke git-command "checkout" "FETCH_HEAD") + (begin + (invoke git-command "fetch" "origin") + (invoke git-command "checkout" commit))) + (when recursive? + ;; Now is the time to fetch sub-modules. + (unless (zero? (system* git-command "submodule" "update" "--init" "--recursive")) - (error "failed to fetch sub-modules" url)) + (error "failed to fetch sub-modules" url)) - ;; In sub-modules, '.git' is a flat file, not a directory, - ;; so we can use 'find-files' here. - (for-each delete-file-recursively - (find-files directory "^\\.git$"))) + ;; In sub-modules, '.git' is a flat file, not a directory, + ;; so we can use 'find-files' here. + (for-each delete-file-recursively + (find-files directory "^\\.git$"))) - ;; The contents of '.git' vary as a function of the current - ;; status of the Git repo. Since we want a fixed output, this - ;; directory needs to be taken out. - (delete-file-recursively ".git") - #t))))) + ;; The contents of '.git' vary as a function of the current + ;; status of the Git repo. Since we want a fixed output, this + ;; directory needs to be taken out. + (delete-file-recursively ".git") + #t)) ;;; git.scm ends here -- cgit v1.2.3 From f44c7aaccd1942b8bf7916e4c8bb0f8f1abfcb58 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 Mar 2018 10:52:32 +0100 Subject: ui: Better workaround for lack of '%fresh-auto-compile' on 2.2.3. Fixes for the most part. * guix/ui.scm (load*): Add call to 'compile-file' on 2.2.3. --- guix/ui.scm | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index fb2380b68a..221bb82b7e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -52,6 +52,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 regex) + #:autoload (system base compile) (compile-file) #:autoload (system repl repl) (start-repl) #:autoload (system repl debug) (make-debug stack->vector) #:use-module (texinfo) @@ -186,8 +187,8 @@ messages." (define (error-string frame args) (call-with-output-string - (lambda (port) - (apply display-error frame port (cdr args))))) + (lambda (port) + (apply display-error frame port (cdr args))))) (define tag (make-prompt-tag "user-code")) @@ -199,11 +200,13 @@ messages." ;; In 2.2.3, the bogus answer to was to ;; ignore all available .go, not just those from ~/.cache, which in turn ;; meant that we had to rebuild *everything*. Since this is too costly, - ;; we have to turn auto '%fresh-auto-compile' with that version, at the - ;; risk of getting ABI breakage in the user's config file. See - ;; . - (unless (string=? (version) "2.2.3") - (set! %fresh-auto-compile #t)) + ;; we have to turn off '%fresh-auto-compile' with that version, so to + ;; avoid ABI breakage in the user's config file, we explicitly compile + ;; it (the problem remains if the user's config is spread on several + ;; modules.) See . + (if (string=? (version) "2.2.3") + (compile-file file #:env user-module) + (set! %fresh-auto-compile #t)) (set! %load-should-auto-compile #t) -- cgit v1.2.3 From 7949c140b10184f82247ea10fbbb344ecd097924 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Mar 2018 10:47:25 +0100 Subject: ui: 'load*' no longer fails on Guile 2.2.3 upon EACCES or similar. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously, if ~/.cache was not write-accessible, 'guix' would exit with code 1 without printing any message. That was because the 'make-stack' call would fail since the exception (a 'system-error) came from 'compile-file', which was called at a point where TAG wasn't installed yet. Secondly, to mimick auto-compilation behavior, we just swallow 'system-error raised by 'compile-file'. Reported by Clément Lassieur. * guix/ui.scm (load*): Move 'compile-file' call in the dynamic extent of TAG. Catch 'system-error around it and ignore it. --- guix/ui.scm | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 221bb82b7e..a4943c2a7f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -204,9 +204,8 @@ messages." ;; avoid ABI breakage in the user's config file, we explicitly compile ;; it (the problem remains if the user's config is spread on several ;; modules.) See . - (if (string=? (version) "2.2.3") - (compile-file file #:env user-module) - (set! %fresh-auto-compile #t)) + (unless (string=? (version) "2.2.3") + (set! %fresh-auto-compile #t)) (set! %load-should-auto-compile #t) @@ -218,6 +217,12 @@ messages." (parameterize ((current-warning-port (%make-void-port "w"))) (call-with-prompt tag (lambda () + (when (string=? (version) "2.2.3") + (catch 'system-error + (lambda () + (compile-file file #:env user-module)) + (const #f))) ;EACCES maybe, let's interpret it + ;; 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 -- cgit v1.2.3 From ca23693d280de5c4031058da4d3041d830080484 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Mar 2018 10:41:06 +0100 Subject: linux-initrd: Factorize 'check-device-initrd-modules'. * gnu/system/mapped-devices.scm (check-device-initrd-modules): Move to... * gnu/system/linux-initrd.scm (check-device-initrd-modules): ... here. New procedure. * po/guix/POTFILES.in: Add it. * guix/scripts/system.scm (check-initrd-modules)[check-device]: Remove. Use 'check-device-initrd-modules' instead. --- gnu/system/linux-initrd.scm | 24 +++++++++++++++++++++++- gnu/system/mapped-devices.scm | 19 ++----------------- guix/scripts/system.scm | 23 +++++------------------ po/guix/POTFILES.in | 1 + 4 files changed, 31 insertions(+), 36 deletions(-) (limited to 'guix') diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index e0cb59c009..d75caed83e 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -24,6 +24,7 @@ #:use-module (guix store) #:use-module (guix gexp) #:use-module (guix utils) + #:use-module (guix i18n) #:use-module ((guix store) #:select (%store-prefix)) #:use-module ((guix derivations) @@ -37,16 +38,22 @@ #:select (%guile-static-stripped)) #:use-module (gnu system file-systems) #:use-module (gnu system mapped-devices) + #:autoload (gnu build linux-modules) + (device-module-aliases matching-modules) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 vlist) + #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (expression->initrd %base-initrd-modules raw-initrd file-system-packages - base-initrd)) + base-initrd + check-device-initrd-modules)) ;;; Commentary: @@ -343,4 +350,19 @@ loaded at boot time in the order in which they appear." #:volatile-root? volatile-root? #:on-error on-error)) +(define (check-device-initrd-modules device linux-modules location) + "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate. +DEVICE must be a \"/dev\" file name." + (let ((modules (delete-duplicates + (append-map matching-modules + (device-module-aliases device))))) + (unless (every (cute member <> linux-modules) modules) + (raise (condition + (&message + (message (format #f (G_ "you may need these modules \ +in the initrd for ~a:~{ ~a~}") + device modules))) + (&error-location + (location (source-properties->location location)))))))) + ;;; linux-initrd.scm ends here diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 5ceb5e658c..e6ac635231 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -29,9 +29,9 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu system uuid) + #:use-module ((gnu system linux-initrd) + #:select (check-device-initrd-modules)) #:autoload (gnu build file-systems) (find-partition-by-luks-uuid) - #:autoload (gnu build linux-modules) - (device-module-aliases matching-modules) #:autoload (gnu packages cryptsetup) (cryptsetup-static) #:autoload (gnu packages linux) (mdadm-static) #:use-module (srfi srfi-1) @@ -154,21 +154,6 @@ #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") "close" #$target))) -(define (check-device-initrd-modules device linux-modules location) - "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate. -DEVICE must be a \"/dev\" file name." - (let ((modules (delete-duplicates - (append-map matching-modules - (device-module-aliases device))))) - (unless (every (cute member <> linux-modules) modules) - (raise (condition - (&message - (message (format #f (G_ "you may need these modules \ -in the initrd for ~a:~{ ~a~}") - device modules))) - (&error-location - (location (source-properties->location location)))))))) - (define* (check-luks-device md #:key needed-for-boot? (initrd-modules '()) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index ff322ec785..acfccce96d 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -43,8 +43,7 @@ (find-partition-by-label find-partition-by-uuid) #:autoload (gnu build linux-modules) (device-module-aliases matching-modules) - #:autoload (gnu system linux-initrd) - (base-initrd default-initrd-modules) + #:use-module (gnu system linux-initrd) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -661,27 +660,15 @@ checking this by themselves in their 'check' procedure." ('uuid (find-partition-by-uuid device)) ('label (find-partition-by-label device))))) - (define (check-device device location) - (let ((modules (delete-duplicates - (append-map matching-modules - (device-module-aliases device))))) - (unless (every (cute member <> (operating-system-initrd-modules os)) - modules) - (raise (condition - (&message - (message (format #f (G_ "you need these modules \ -in the initrd for ~a:~{ ~a~}") - device modules))) - (&error-location (location location))))))) - (define file-systems (filter file-system-needed-for-boot? (operating-system-file-systems os))) (for-each (lambda (fs) - (check-device (file-system-/dev fs) - (source-properties->location - (file-system-location fs)))) + (check-device-initrd-modules (file-system-/dev fs) + (operating-system-initrd-modules os) + (source-properties->location + (file-system-location fs)))) file-systems)) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 6510b99e8f..ba09605375 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -5,6 +5,7 @@ gnu/packages.scm gnu/services.scm gnu/system.scm gnu/services/shepherd.scm +gnu/system/linux-initrd.scm gnu/system/shadow.scm guix/scripts.scm guix/scripts/build.scm -- cgit v1.2.3 From e1ba6d49ea4df327e4dde9a994c4a89b71484d69 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Mar 2018 10:52:24 +0100 Subject: ui: Display fix hints in the case where we have location info. * guix/ui.scm (call-with-error-handling): Display fix-hints in the error + message case. --- guix/ui.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index a4943c2a7f..5b87f1e29b 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -639,6 +639,8 @@ directories:~{ ~a~}~%") (G_ "~a: error: ~a~%") (location->string (error-location c)) (gettext (condition-message c) %gettext-domain)) + (when (fix-hint? c) + (display-hint (condition-fix-hint c))) (exit 1)) ((and (message-condition? c) (fix-hint? c)) (format (current-error-port) "~a: error: ~a~%" -- cgit v1.2.3 From 16de45557f782d23a87ae2fa394267d5826e834a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Mar 2018 10:53:16 +0100 Subject: ui: 'display-hint' preserves Texinfo formatting. The previous method would mess up with @example formatting, for instance. * guix/ui.scm (display-hint): Parameterize '%text-width' instead of using 'fill-paragraph'. --- guix/ui.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 5b87f1e29b..cb49a15c4d 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -299,8 +299,10 @@ VARIABLE and return it, or #f if none was found." "Display MESSAGE, a l10n message possibly containing Texinfo markup, to PORT." (format port (G_ "hint: ~a~%") - (fill-paragraph (texi->plain-text message) - (terminal-columns) 8))) + ;; XXX: We should arrange so that the initial indent is wider. + (parameterize ((%text-width (max 15 + (- (terminal-columns) 5)))) + (texi->plain-text message)))) (define* (report-load-error file args #:optional frame) "Report the failure to load FILE, a user-provided Scheme file. -- cgit v1.2.3 From 33286075b9c2ecd27607b5674c68909dd528473a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 Mar 2018 11:47:28 +0100 Subject: hash: Add 'sha1'. * guix/hash.scm (GCRY_MD_SHA1): New macro. (bytevector-hash): New procedure. (sha256): Express in terms of 'bytevector-hash'. (sha1): New procedure. * tests/hash.scm ("sha1, empty", "sha1, hello"): New tests. --- guix/hash.scm | 23 +++++++++++++++++------ tests/hash.scm | 8 ++++++++ 2 files changed, 25 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/hash.scm b/guix/hash.scm index 773b9d4777..39834043e1 100644 --- a/guix/hash.scm +++ b/guix/hash.scm @@ -23,7 +23,9 @@ #:use-module (system foreign) #:use-module ((guix build utils) #:select (dump-port)) #:use-module (srfi srfi-11) - #:export (sha256 + #:use-module (srfi srfi-26) + #:export (sha1 + sha256 open-sha256-port port-sha256 file-sha256 @@ -44,17 +46,26 @@ ;; Value as of Libgcrypt 1.5.2. (identifier-syntax 8)) -(define sha256 +(define-syntax GCRY_MD_SHA1 + (identifier-syntax 2)) + +(define bytevector-hash (let ((hash (pointer->procedure void (libgcrypt-func "gcry_md_hash_buffer") `(,int * * ,size_t)))) - (lambda (bv) - "Return the SHA256 of BV as a bytevector." - (let ((digest (make-bytevector (/ 256 8)))) - (hash GCRY_MD_SHA256 (bytevector->pointer digest) + (lambda (bv type size) + "Return the hash TYPE, of SIZE bytes, of BV as a bytevector." + (let ((digest (make-bytevector size))) + (hash type (bytevector->pointer digest) (bytevector->pointer bv) (bytevector-length bv)) digest)))) +(define sha1 + (cut bytevector-hash <> GCRY_MD_SHA1 20)) + +(define sha256 + (cut bytevector-hash <> GCRY_MD_SHA256 (/ 256 8))) + (define open-sha256-md (let ((open (pointer->procedure int (libgcrypt-func "gcry_md_open") diff --git a/tests/hash.scm b/tests/hash.scm index b4cf2b61d6..da87616eec 100644 --- a/tests/hash.scm +++ b/tests/hash.scm @@ -40,6 +40,14 @@ (test-begin "hash") +(test-equal "sha1, empty" + (base16-string->bytevector "da39a3ee5e6b4b0d3255bfef95601890afd80709") + (sha1 #vu8())) + +(test-equal "sha1, hello" + (base16-string->bytevector "2aae6c35c94fcfb415dbe95f408b9ce91ee846ed") + (sha1 (string->utf8 "hello world"))) + (test-equal "sha256, empty" %empty-sha256 (sha256 #vu8())) -- cgit v1.2.3 From ad1d03fcf0472c88c9f63e8126274320cb0a076e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 12 Mar 2018 15:14:01 +0100 Subject: build-system: minify: Do not import (ice-9 popen) in the build environment. The (ice-9 popen) module should not be added to the imported-modules here, because that depends on the Guile that is used on the host side. * guix/build-system/minify.scm (%minify-build-system-modules): Remove import of (ice-9 popen). --- guix/build-system/minify.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm index af90a32f59..21d84a179a 100644 --- a/guix/build-system/minify.scm +++ b/guix/build-system/minify.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,7 +39,6 @@ (define %minify-build-system-modules ;; Build-side modules imported by default. `((guix build minify-build-system) - (ice-9 popen) ,@%gnu-build-system-modules)) (define (default-uglify-js) -- cgit v1.2.3