From f8121329b1dcebb55d6dfbae553bfa69d557eede Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Sep 2018 14:45:19 +0200 Subject: syscalls: Report lack of a libc symbol as ENOSYS. * guix/build/syscalls.scm (syscall->procedure): Throw to 'system-error with ENOSYS when NAME cannot be found. --- guix/build/syscalls.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 74cb675fcf..56a689f667 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -385,8 +385,8 @@ the returned procedure is called." #:return-errno? #t))) (lambda args (lambda _ - (error (format #f "~a: syscall->procedure failed: ~s" - name args)))))) + (throw 'system-error name "~A" (list (strerror ENOSYS)) + (list ENOSYS)))))) (define-syntax define-as-needed (syntax-rules () -- cgit v1.2.3 From 7d05868847c477c75d2c5af3aa4d7baae862191c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Sep 2018 14:46:00 +0200 Subject: substitute: Ignore exceptions thrown by 'set-thread-name'. Fixes . Reported by Ricardo Wurmus . * guix/scripts/substitute.scm (guix-substitute): Swallow 'system-error' exceptions around 'set-thread-name' call. --- guix/scripts/substitute.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index cd300195d8..6d31dfdaa4 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1087,7 +1087,10 @@ default value." (#f #f) (locale (false-if-exception (setlocale LC_ALL locale)))) - (set-thread-name "guix substitute") + (catch 'system-error + (lambda () + (set-thread-name "guix substitute")) + (const #t)) ;GNU/Hurd lacks 'prctl' (with-networking (with-error-handling ; for signature errors -- cgit v1.2.3 From 875d0681768408997cda108457aaf10116da3732 Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Mon, 10 Sep 2018 15:42:07 -0400 Subject: Adjust all users of (gnu packages ldc) to use (gnu packages dlang). This is a followup to commit 98d6543f86d01486c2f6e808eedd97c601ba3e7a. * gnu/packages/bioinformatics.scm, guix/build-system/dub.scm: Adjust accordingly. --- gnu/packages/bioinformatics.scm | 2 +- guix/build-system/dub.scm | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/gnu/packages/bioinformatics.scm b/gnu/packages/bioinformatics.scm index fc8be4d7db..f6410c3ca4 100644 --- a/gnu/packages/bioinformatics.scm +++ b/gnu/packages/bioinformatics.scm @@ -76,7 +76,7 @@ #:use-module (gnu packages imagemagick) #:use-module (gnu packages java) #:use-module (gnu packages jemalloc) - #:use-module (gnu packages ldc) + #:use-module (gnu packages dlang) #:use-module (gnu packages linux) #:use-module (gnu packages logging) #:use-module (gnu packages machine-learning) diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm index 13c89e8648..5a31a2f51a 100644 --- a/guix/build-system/dub.scm +++ b/guix/build-system/dub.scm @@ -35,13 +35,13 @@ (define (default-ldc) "Return the default ldc package." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((ldc (resolve-interface '(gnu packages ldc)))) + (let ((ldc (resolve-interface '(gnu packages dlang)))) (module-ref ldc 'ldc))) (define (default-dub) "Return the default dub package." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((ldc (resolve-interface '(gnu packages ldc)))) + (let ((ldc (resolve-interface '(gnu packages dlang)))) (module-ref ldc 'dub))) (define (default-pkg-config) -- cgit v1.2.3 From 2225d56a14a2d8d29374a14eefe90b3cffa79804 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 10 Sep 2018 23:37:48 +0200 Subject: profiles: Correctly deal with etc/ being a relative symlink. Fixes . Reported by Oleg Pykhalov . * guix/build/profiles.scm (ensure-writable-directory): Add #:symlink. [absolute?]: New procedure. [unsymlink]: Use it to determine how to resolve readlink's result. (build-profile): Pass SYMLINK to 'ensure-writable-directory'. * tests/profiles.scm ("profile-derivation when etc/ is a relative symlink"): New test. --- guix/build/profiles.scm | 15 ++++++++++++--- tests/profiles.scm | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 48 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index df785c85a7..0c23cd300e 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -94,12 +94,20 @@ definitions for all the SEARCH-PATHS." (for-each (write-environment-variable-definition port) (map (abstract-profile output) variables)))))) -(define (ensure-writable-directory directory) +(define* (ensure-writable-directory directory + #:key (symlink symlink)) "Ensure DIRECTORY exists and is writable. If DIRECTORY is currently a symlink (to a read-only directory in the store), then delete the symlink and instead make DIRECTORY a \"real\" directory containing symlinks." + (define (absolute? file) + (string-prefix? "/" file)) + (define (unsymlink link) - (let* ((target (readlink link)) + (let* ((target (match (readlink link) + ((? absolute? target) + target) + ((? string? relative) + (string-append (dirname link) "/" relative)))) ;; TARGET might itself be a symlink, so append "/" to make sure ;; 'scandir' enters it. (files (scandir (string-append target "/") @@ -149,7 +157,8 @@ SEARCH-PATHS." ;; Make sure we can write to 'OUTPUT/etc'. 'union-build' above could have ;; made 'etc' a symlink to a read-only sub-directory in the store so we need ;; to work around that. - (ensure-writable-directory (string-append output "/etc")) + (ensure-writable-directory (string-append output "/etc") + #:symlink symlink) ;; Write 'OUTPUT/etc/profile'. (build-etc/profile output search-paths)) diff --git a/tests/profiles.scm b/tests/profiles.scm index 3a59a0cc4f..9f366a04ef 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -20,6 +20,7 @@ (define-module (test-profiles) #:use-module (guix tests) #:use-module (guix profiles) + #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix grafts) @@ -543,6 +544,41 @@ get-string-all) "foo!")))))) +(test-assertm "profile-derivation when etc/ is a relative symlink" + ;; See . + (mlet* %store-monad + ((etc (gexp->derivation + "etc" + #~(begin + (mkdir #$output) + (call-with-output-file (string-append #$output "/foo") + (lambda (port) + (display "Heya!" port)))))) + (thing -> (dummy-package "dummy" + (build-system trivial-build-system) + (inputs + `(("etc" ,etc))) + (arguments + `(#:guile ,%bootstrap-guile + #:builder + (let ((out (assoc-ref %outputs "out")) + (etc (assoc-ref %build-inputs "etc"))) + (mkdir out) + (symlink etc (string-append out "/etc")) + #t))))) + (entry -> (package->manifest-entry thing)) + (drv (profile-derivation (manifest (list entry)) + #:relative-symlinks? #t + #:hooks '() + #:locales? #f)) + (profile -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (string=? (call-with-input-file + (string-append profile "/etc/foo") + get-string-all) + "Heya!"))))) + (test-equalm "union vs. dangling symlink" ; "does-not-exist" (mlet* %store-monad -- cgit v1.2.3 From f72e5f93b7ba874ecc66ba419f71f384d1b7903d Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 11 Sep 2018 22:16:24 +0200 Subject: ui: Do not filter hash mismatch lines. Reported by Pjotr Prins . * guix/ui.scm (build-output-port): Add pattern for hash mismatch error; be more careful with error messages in verbose mode. --- guix/ui.scm | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 1bbd37c255..c55ae7e2f8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1708,12 +1708,26 @@ phase announcements and replaces any other output with a spinner." (string-append (proc "Building " 'BLUE 'BOLD) (match:substring m 2) "\n"))) - ("^(@ build-failed) (.*) (.*)" - #:transform - ,(lambda (m) - (string-append - (proc "Build failed: " 'RED 'BOLD) - (match:substring m 2) "\n"))) + ,(if verbose? + ;; Err on the side of caution: show everything, even + ;; if it might be redundant. + `("^(@ build-failed)(.+)" + #:transform + ,(lambda (m) + (string-append + (proc "Build failed: " 'RED 'BOLD) + (match:substring m 2)))) + ;; Show only that the build failed. + `("^(@ build-failed)(.+) -.*" + #:transform + ,(lambda (m) + (string-append + (proc "Build failed: " 'RED 'BOLD) + (match:substring m 2) + "\n")))) + ;; NOTE: this line contains "\n" characters. + ("^(sha256 hash mismatch for output path)(.*)" + RED BLACK) ("^(@ build-succeeded) (.*) (.*)" #:transform ,(lambda (m) -- cgit v1.2.3 From 1afd1fbf3cf1d1283a009d5cbb8ad698bff4dd48 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 11 Sep 2018 23:17:54 +0200 Subject: guix: Do not close current-error-port. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reported-by: Ludovic Courtès . * guix/scripts/build.scm (guix-build), guix/scripts/package.scm (guix-package): Duplicate port before handing it to build-output-port. --- guix/scripts/build.scm | 8 +++++--- guix/scripts/package.scm | 3 ++- 2 files changed, 7 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 3fa3c2c20f..9d38610633 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -733,9 +733,11 @@ needed." ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((current-build-output-port (if quiet? - (%make-void-port "w") - (build-output-port #:verbose? #t)))) + (parameterize ((current-build-output-port + (if quiet? + (%make-void-port "w") + (build-output-port #:verbose? #t + #:port (duplicate-port (current-error-port) "w"))))) (let* ((mode (assoc-ref opts 'build-mode)) (drv (options->derivations store opts)) (urls (map (cut string-append <> "/log") diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 73cbccba3b..c3ed2ac935 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -950,5 +950,6 @@ processed, #f otherwise." %bootstrap-guile (canonical-package guile-2.2)))) (current-build-output-port - (build-output-port #:verbose? verbose?))) + (build-output-port #:verbose? verbose? + #:port (duplicate-port (current-error-port) "w")))) (process-actions (%store) opts)))))) -- cgit v1.2.3 From aed0a594058a59bc3bb1d2686391dc0e8a181b1f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 12 Sep 2018 23:56:34 +0200 Subject: git-download: Rewrite 'git-predicate' using Guile-Git. Fixes . * guix/git-download.scm (files->directory-tree) (directory-in-tree?): Remove. (git-file-list): New procedures. (git-predicate): Use it instead of opening a pipe to 'git'. Remove directory tree hack and rely exclusively on inode/device numbers. --- guix/git-download.scm | 119 ++++++++++++++++++-------------------------------- 1 file changed, 42 insertions(+), 77 deletions(-) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index 33f102bc6c..e6e0ec2ac5 100644 --- a/guix/git-download.scm +++ b/guix/git-download.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 © 2017 Mathieu Lirzin ;;; Copyright © 2017 Christopher Baines ;;; @@ -19,7 +19,6 @@ ;;; along with GNU Guix. If not, see . (define-module (guix git-download) - #:use-module (guix build utils) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) @@ -27,9 +26,8 @@ #:use-module (guix packages) #:use-module (guix modules) #:autoload (guix build-system gnu) (standard-packages) + #:use-module (git) #:use-module (ice-9 match) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:export (git-reference @@ -153,41 +151,31 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;;; 'git-predicate'. ;;; -(define (files->directory-tree files) - "Return a tree of vhashes representing the directory listed in FILES, a list -like '(\"a/b\" \"b/c/d\")." - (fold (lambda (file result) - (let loop ((file (string-split file #\/)) - (result result)) - (match file - ((_) - result) - ((directory children ...) - (match (vhash-assoc directory result) - (#f - (vhash-cons directory (loop children vlist-null) - result)) - ((_ . previous) - ;; XXX: 'vhash-delete' is O(n). - (vhash-cons directory (loop children previous) - (vhash-delete directory result))))) - (() - result)))) - vlist-null - files)) - -(define (directory-in-tree? tree directory) - "Return true if DIRECTORY, a string like \"a/b\", denotes a directory listed -in TREE." - (let loop ((directory (string-split directory #\/)) - (tree tree)) - (match directory - (() - #t) - ((head . tail) - (match (vhash-assoc head tree) - ((_ . sub-tree) (loop tail sub-tree)) - (#f #f)))))) +(define (git-file-list directory) + "Return the list of files checked in in the Git repository at DIRECTORY. +The result is similar to that of the 'git ls-files' command, except that it +also includes directories, not just regular files. The returned file names +are relative to DIRECTORY, which is not necessarily the root of the checkout." + (let* ((directory (canonicalize-path directory)) + (dot-git (repository-discover directory)) + (top (dirname dot-git)) + (repository (repository-open dot-git)) + (head (repository-head repository)) + (oid (reference-target head)) + (commit (commit-lookup repository oid)) + (tree (commit-tree commit)) + (files (tree-list tree))) + (repository-close! repository) + (if (string=? top directory) + files + (let ((relative (string-append + (string-drop directory + (+ 1 (string-length top))) + "/"))) + (filter-map (lambda (file) + (and (string-prefix? relative file) + (string-drop file (string-length relative)))) + files))))) (define (git-predicate directory) "Return a predicate that returns true if a file is part of the Git checkout @@ -195,43 +183,20 @@ living at DIRECTORY. Upon Git failure, return #f instead of a predicate. The returned predicate takes two arguments FILE and STAT where FILE is an absolute file name and STAT is the result of 'lstat'." - (let* ((pipe (with-directory-excursion directory - (open-pipe* OPEN_READ "git" "ls-files"))) - (files (let loop ((lines '())) - (match (read-line pipe) - ((? eof-object?) - (reverse lines)) - (line - (loop (cons line lines)))))) - (directory-tree (files->directory-tree files)) - (inodes (fold (lambda (file result) - (let ((stat - (lstat (string-append directory "/" - file)))) - (vhash-consv (stat:ino stat) (stat:dev stat) - result))) - vlist-null - files)) - - ;; Note: For this to work we must *not* call 'canonicalize-path' on - ;; DIRECTORY or we would get discrepancies of the returned lambda is - ;; called with a non-canonical file name. - (prefix-length (+ 1 (string-length directory))) - - (status (close-pipe pipe))) - (and (zero? status) - (lambda (file stat) - (match (stat:type stat) - ('directory - (directory-in-tree? directory-tree - (string-drop file prefix-length))) - ((or 'regular 'symlink) - ;; Comparing file names is always tricky business so we rely on - ;; inode numbers instead - (match (vhash-assv (stat:ino stat) inodes) - ((_ . dev) (= dev (stat:dev stat))) - (#f #f))) - (_ - #f)))))) + (let* ((files (git-file-list directory)) + (inodes (fold (lambda (file result) + (let ((stat + (lstat (string-append directory "/" + file)))) + (vhash-consv (stat:ino stat) (stat:dev stat) + result))) + vlist-null + files))) + (lambda (file stat) + ;; Comparing file names is always tricky business so we rely on inode + ;; numbers instead. + (match (vhash-assv (stat:ino stat) inodes) + ((_ . dev) (= dev (stat:dev stat))) + (#f #f))))) ;;; git-download.scm ends here -- cgit v1.2.3