From af98798c7aad8c4576d4f7e49343980606cadc20 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 May 2016 18:02:04 +0200 Subject: union: Compare inode numbers in 'file=?'. * guix/build/union.scm (file=?): Compare the inode of ST1 and ST2. --- guix/build/union.scm | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) (limited to 'guix/build') diff --git a/guix/build/union.scm b/guix/build/union.scm index ccd2d5c103..6640b56523 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès ;;; Copyright © 2014 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -53,22 +53,24 @@ identical, #f otherwise." (let ((st1 (stat file1)) (st2 (stat file2))) - (and (eq? (stat:type st1) 'regular) - (eq? (stat:type st2) 'regular) - (= (stat:size st1) (stat:size st2)) - (call-with-input-file file1 - (lambda (port1) - (call-with-input-file file2 - (lambda (port2) - (define len 8192) - (define buf1 (make-bytevector len)) - (define buf2 (make-bytevector len)) - (let loop () - (let ((n1 (get-bytevector-n! port1 buf1 0 len)) - (n2 (get-bytevector-n! port2 buf2 0 len))) - (and (equal? n1 n2) - (or (eof-object? n1) - (loop)))))))))))) + ;; When deduplication is enabled, identical files share the same inode. + (or (= (stat:ino st1) (stat:ino st2)) + (and (eq? (stat:type st1) 'regular) + (eq? (stat:type st2) 'regular) + (= (stat:size st1) (stat:size st2)) + (call-with-input-file file1 + (lambda (port1) + (call-with-input-file file2 + (lambda (port2) + (define len 8192) + (define buf1 (make-bytevector len)) + (define buf2 (make-bytevector len)) + (let loop () + (let ((n1 (get-bytevector-n! port1 buf1 0 len)) + (n2 (get-bytevector-n! port2 buf2 0 len))) + (and (equal? n1 n2) + (or (eof-object? n1) + (loop))))))))))))) (define* (union-build output inputs #:key (log-port (current-error-port))) -- cgit v1.2.3 From 007c20b61c84af11289f96d43374e2e688838a26 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 May 2016 23:49:26 +0200 Subject: graft: Fail when one of the threads raises an exception. Fixes . * guix/build/graft.scm (exit-on-exception): New procedure. (rewrite-directory): Use it to wrap REWRITE-LEAF. --- guix/build/graft.scm | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) (limited to 'guix/build') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index b61982dd64..fb21fc3af3 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -105,6 +105,19 @@ a list of store file name pairs." (string-append (dirname file) "/" target)))) matches))) +(define (exit-on-exception proc) + "Return a procedure that wraps PROC so that 'primitive-exit' is called when +an exception is caught." + (lambda (arg) + (catch #t + (lambda () + (proc arg)) + (lambda (key . args) + ;; Since ports are not thread-safe as of Guile 2.0, reopen stderr. + (let ((port (fdopen 2 "w0"))) + (print-exception port #f key args) + (primitive-exit 1)))))) + (define* (rewrite-directory directory output mapping #:optional (store (%store-directory))) "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of @@ -147,9 +160,13 @@ file name pairs." ;; #o777. (umask #o022) + ;; Use 'exit-on-exception' to force an exit upon I/O errors, given that + ;; 'n-par-for-each' silently swallows exceptions. + ;; See . (n-par-for-each (parallel-job-count) - rewrite-leaf (find-files directory (const #t) - #:directories? #t)) + (exit-on-exception rewrite-leaf) + (find-files directory (const #t) + #:directories? #t)) (rename-matching-files output mapping)) ;;; graft.scm ends here -- cgit v1.2.3 From 25c288cbf12925e0f079a2ebb0247a21e14dc6b8 Mon Sep 17 00:00:00 2001 From: Ben Woodcroft Date: Sun, 22 May 2016 08:46:39 +1000 Subject: guix: ruby-build-system: Extract gemspec during 'extract-gemspec'. * guix/build/ruby-build-system.scm (build): Move extraction from here ... (extract-gemspec): ... to here. New variable. (first-gemspec): New variable. (%standard-phases): Add 'extract-gemspec' phase. --- guix/build/ruby-build-system.scm | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) (limited to 'guix/build') diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index a4ac3b307c..79ac380cb8 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -66,14 +66,13 @@ directory." ;; Use GNU unpack strategy for things that aren't gem archives. (gnu:unpack #:source source))) -(define* (build #:key source #:allow-other-keys) - "Build a new gem using the gemspec from the SOURCE gem." - (define (first-gemspec) - (first-matching-file "\\.gemspec$")) +(define (first-gemspec) + (first-matching-file "\\.gemspec$")) - ;; Remove the original gemspec, if present, and replace it with a new one. - ;; This avoids issues with upstream gemspecs requiring tools such as git to - ;; generate the files list. +(define* (extract-gemspec #:key source #:allow-other-keys) + "Remove the original gemspec, if present, and replace it with a new one. +This avoids issues with upstream gemspecs requiring tools such as git to +generate the files list." (when (gem-archive? source) (let ((gemspec (or (false-if-exception (first-gemspec)) ;; Make new gemspec if one wasn't shipped. @@ -94,7 +93,10 @@ directory." (write-char (read-char pipe) out)))) #t) (lambda () - (close-pipe pipe)))))) + (close-pipe pipe))))))) + +(define* (build #:key source #:allow-other-keys) + "Build a new gem using the gemspec from the SOURCE gem." ;; Build a new gem from the current working directory. This also allows any ;; dynamic patching done in previous phases to be present in the installed @@ -134,6 +136,7 @@ GEM-FLAGS are passed to the 'gem' invokation, if present." (define %standard-phases (modify-phases gnu:%standard-phases (delete 'configure) + (add-before 'build 'extract-gemspec extract-gemspec) (replace 'build build) (replace 'unpack unpack) (replace 'install install) -- cgit v1.2.3 From dab2472c6a24630db7c524cb997d358a33820ffd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 May 2016 10:29:10 +0200 Subject: download: Use URI objects for content-addressed mirrors. This fixes a bug whereby 'http-fetch' would be passed a string instead of a URI object. * guix/build/download.scm (url-fetch): Rename 'content-addressed-urls' to 'content-addressed-uris', and call 'string->uri'. --- guix/build/download.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index 7741726c41..ef515efdbf 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -719,11 +719,11 @@ or #f." uri) #f))) - (define content-addressed-urls + (define content-addressed-uris (append-map (lambda (make-url) (filter-map (match-lambda ((hash-algo . hash) - (make-url hash-algo hash))) + (string->uri (make-url hash-algo hash)))) hashes)) content-addressed-mirrors)) @@ -733,7 +733,7 @@ or #f." (setvbuf (current-error-port) _IOLBF) - (let try ((uri (append uri content-addressed-urls))) + (let try ((uri (append uri content-addressed-uris))) (match uri ((uri tail ...) (or (fetch uri file) -- cgit v1.2.3 From b18ede2704ca1b1bdfa5a0d5655bee90ef05fa0f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 May 2016 10:33:23 +0200 Subject: download: Default to a 10s connection establishment timeout. * guix/build/download.scm (ftp-fetch): Add #:timeout and pass it to 'ftp-open'. (http-fetch): Add #:timeout and pass it to 'open-connection-for-uri' and in recursive calls. (url-fetch): Add #:timeout and pass it to 'http-fetch' and 'ftp-fetch'. --- guix/build/download.scm | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index ef515efdbf..bd011ce878 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -234,9 +234,10 @@ and 'guix publish', something like (string-drop path 33) path))) -(define (ftp-fetch uri file) - "Fetch data from URI and write it to FILE. Return FILE on success." - (let* ((conn (ftp-open (uri-host uri))) +(define* (ftp-fetch uri file #:key timeout) + "Fetch data from URI and write it to FILE. Return FILE on success. Bail +out if the connection could not be established in less than TIMEOUT seconds." + (let* ((conn (ftp-open (uri-host uri) #:timeout timeout)) (size (false-if-exception (ftp-size conn (uri-path uri)))) (in (ftp-retr conn (basename (uri-path uri)) (dirname (uri-path uri))))) @@ -585,8 +586,10 @@ Return the resulting target URI." #:query (uri-query ref) #:fragment (uri-fragment ref))))) -(define (http-fetch uri file) - "Fetch data from URI and write it to FILE. Return FILE on success." +(define* (http-fetch uri file #:key timeout) + "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if +the connection could not be established in less than TIMEOUT seconds. Return +FILE on success." (define post-2.0.7? (or (> (string->number (major-version)) 2) @@ -605,7 +608,7 @@ Return the resulting target URI." (Accept . "*/*"))) (let*-values (((connection) - (open-connection-for-uri uri)) + (open-connection-for-uri uri #:timeout timeout)) ((resp bv-or-port) ;; XXX: `http-get*' was introduced in 2.0.7, and replaced by ;; #:streaming? in 2.0.8. We know we're using it within the @@ -646,7 +649,7 @@ Return the resulting target URI." (format #t "following redirection to `~a'...~%" (uri->string uri)) (close connection) - (http-fetch uri file))) + (http-fetch uri file #:timeout timeout))) (else (error "download failed" (uri->string uri) code (response-reason-phrase resp)))))) @@ -686,6 +689,7 @@ Return a list of URIs." (define* (url-fetch url file #:key + (timeout 10) (mirrors '()) (content-addressed-mirrors '()) (hashes '())) "Fetch FILE from URL; URL may be either a single string, or a list of @@ -711,9 +715,9 @@ or #f." file (uri->string uri)) (case (uri-scheme uri) ((http https) - (false-if-exception* (http-fetch uri file))) + (false-if-exception* (http-fetch uri file #:timeout timeout))) ((ftp) - (false-if-exception* (ftp-fetch uri file))) + (false-if-exception* (ftp-fetch uri file #:timeout timeout))) (else (format #t "skipping URI with unsupported scheme: ~s~%" uri) -- cgit v1.2.3 From 578b96af69057883a2a49a34dd6fe261cb2f4e5c Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 27 May 2016 09:58:39 -0400 Subject: build: emacs: Handle sources that are a single elisp file. * guix/build/emacs-build-system.scm (gnu:unpack) (store-file->elisp-source-file, unpack): New procedures. (%standard-phases): Use the new unpack procedure. --- guix/build/emacs-build-system.scm | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) (limited to 'guix/build') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index f0a9a6e125..ab970012a7 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -21,6 +21,7 @@ #:use-module (guix build utils) #:use-module (guix build emacs-utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) @@ -39,6 +40,27 @@ ;; archive signature. (define %install-suffix "/share/emacs/site-lisp/guix.d") +(define gnu:unpack (assoc-ref gnu:%standard-phases 'unpack)) + +(define (store-file->elisp-source-file file) + "Convert FILE, a store file name for an Emacs Lisp source file, into a file +name that has been stripped of the hash and version number." + (let-values (((name version) + (package-name->name+version + (strip-store-file-name file)))) + (string-append name ".el"))) + +(define* (unpack #:key source #:allow-other-keys) + "Unpack SOURCE into the build directory. SOURCE may be a compressed +archive, a directory, or an Emacs Lisp file." + (if (string-suffix? ".el" source) + (begin + (mkdir "source") + (chdir "source") + (copy-file source (store-file->elisp-source-file source)) + #t) + (gnu:unpack #:source source))) + (define* (build #:key outputs inputs #:allow-other-keys) "Compile .el files." (let* ((emacs (string-append (assoc-ref inputs "emacs") "/bin/emacs")) @@ -151,6 +173,7 @@ second hyphen. This corresponds to 'name-version' as used in ELPA packages." (define %standard-phases (modify-phases gnu:%standard-phases + (replace 'unpack unpack) (delete 'configure) (delete 'check) (delete 'install) -- cgit v1.2.3 From 8bebe00a76012a07e91930dcfd68058d4309ae99 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Jun 2016 18:06:58 +0200 Subject: bournish: Handle EOF in the reader. * guix/build/bournish.scm (read-bournish): Add case for EOF. --- guix/build/bournish.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix/build') diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm index 4022796658..3bea1c80c2 100644 --- a/guix/build/bournish.scm +++ b/guix/build/bournish.scm @@ -134,8 +134,10 @@ commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n")) (define (read-bournish port env) "Read a Bournish expression from PORT, and return the corresponding Scheme code as an sexp." - (match (string-tokenize (read-line port)) - ((command args ...) + (match (read-line port) + ((? eof-object? eof) + eof) + ((= string-tokenize (command args ...)) (match (assoc command %commands) ((command proc) ;built-in command (apply proc (map expand-variable args))) -- cgit v1.2.3 From f82c58539e1f7b9b864e68ea2ab0c6a17c15fbb5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Jun 2016 18:12:31 +0200 Subject: bournish: Allow compilation of multiple expressions. * guix/build/bournish.scm (%bournish-language): Add a joiner to SCHEME. Compile only to Scheme. * tests/bournish.scm: New file. * Makefile.am (SCM_TESTS): Add it. --- Makefile.am | 1 + guix/build/bournish.scm | 17 +++++++++++++++-- tests/bournish.scm | 42 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 58 insertions(+), 2 deletions(-) create mode 100644 tests/bournish.scm (limited to 'guix/build') diff --git a/Makefile.am b/Makefile.am index 8ab574b401..50cde52701 100644 --- a/Makefile.am +++ b/Makefile.am @@ -248,6 +248,7 @@ SCM_TESTS = \ tests/profiles.scm \ tests/syscalls.scm \ tests/gremlin.scm \ + tests/bournish.scm \ tests/lint.scm \ tests/publish.scm \ tests/scripts.scm \ diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm index 3bea1c80c2..1f17e0a22d 100644 --- a/guix/build/bournish.scm +++ b/guix/build/bournish.scm @@ -149,11 +149,24 @@ code as an sexp." (define %bournish-language (let ((scheme (lookup-language 'scheme))) + ;; XXX: The 'scheme' language lacks a "joiner", so we add one here. This + ;; allows us to have 'read-bournish' read one shell statement at a time + ;; instead of having to read until EOF. + (set! (language-joiner scheme) + (lambda (exps env) + (match exps + (() '(begin)) + ((exp) exp) + (_ `(begin ,@exps))))) + (make-language #:name 'bournish #:title "Bournish" + + ;; The reader does all the heavy lifting. #:reader read-bournish - #:compilers (language-compilers scheme) - #:decompilers (language-decompilers scheme) + #:compilers `((scheme . ,(lambda (exp env options) + (values exp env env)))) + #:decompilers '() #:evaluator (language-evaluator scheme) #:printer (language-printer scheme) #:make-default-environment diff --git a/tests/bournish.scm b/tests/bournish.scm new file mode 100644 index 0000000000..0f529ce42f --- /dev/null +++ b/tests/bournish.scm @@ -0,0 +1,42 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 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-bournish) + #:use-module (guix build bournish) + #:use-module (system base compile) + #:use-module (system base language) + #:use-module (srfi srfi-64)) + + +(test-begin "bournish") + +(test-equal "single statement" + '(chdir "/foo") + (read-and-compile (open-input-string "cd /foo") + #:from %bournish-language #:to 'scheme)) + +(test-equal "multiple statements" + '(begin + (chdir "/foo") + (getcwd) + ((@@ (guix build bournish) ls-command-implementation))) + (read-and-compile (open-input-string "cd /foo\npwd\nls") + #:from %bournish-language #:to 'scheme)) + +(test-end "bournish") + -- cgit v1.2.3