diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/hg.scm | 51 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 31 | ||||
| -rw-r--r-- | guix/gexp.scm | 33 | ||||
| -rw-r--r-- | guix/hg-download.scm | 84 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 113 | ||||
| -rw-r--r-- | guix/packages.scm | 40 | ||||
| -rw-r--r-- | guix/store.scm | 60 | ||||
| -rw-r--r-- | guix/utils.scm | 27 |
8 files changed, 344 insertions, 95 deletions
diff --git a/guix/build/hg.scm b/guix/build/hg.scm new file mode 100644 index 0000000000..ae4574de57 --- /dev/null +++ b/guix/build/hg.scm @@ -0,0 +1,51 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix build hg) + #:use-module (guix build utils) + #:export (hg-fetch)) + +;;; Commentary: +;;; +;;; This is the build-side support code of (guix hg-download). It allows a +;;; Mercurial repository to be cloned and checked out at a specific changeset +;;; identifier. +;;; +;;; Code: + +(define* (hg-fetch url changeset directory + #:key (hg-command "hg")) + "Fetch CHANGESET from URL into DIRECTORY. CHANGESET must be a valid +Mercurial changeset identifier. Return #t on success, #f otherwise." + + (and (zero? (system* hg-command + "clone" url + "--rev" changeset + ;; Disable TLS certificate verification. The hash of + ;; the checkout is known in advance anyway. + "--insecure" + directory)) + (with-directory-excursion directory + (begin + ;; The contents of '.hg' vary as a function of the current + ;; status of the Mercurial repo. Since we want a fixed + ;; output, this directory needs to be taken out. + (delete-file-recursively ".hg") + #t)))) + +;;; hg.scm ends here diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 48ff227e10..c663899160 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -64,6 +64,7 @@ processes mkdtemp! + fdatasync pivot-root fcntl-flock @@ -493,8 +494,7 @@ user-land process." <)) (define mkdtemp! - (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link))) - (proc (pointer->procedure '* ptr '(*)))) + (let ((proc (syscall->procedure '* "mkdtemp" '(*)))) (lambda (tmpl) "Create a new unique directory in the file system using the template string TMPL and return its file name. TMPL must end with 'XXXXXX'." @@ -506,6 +506,20 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (list err))) (pointer->string result))))) +(define fdatasync + (let ((proc (syscall->procedure int "fdatasync" (list int)))) + (lambda (port) + "Flush buffered output of PORT, an output file port, and then call +fdatasync(2) on the underlying file descriptor." + (force-output port) + (let* ((fd (fileno port)) + (ret (proc fd)) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "fdatasync" "~S: ~A" + (list fd (strerror err)) + (list err))))))) + (define-record-type <file-system> (file-system type block-size blocks blocks-free @@ -611,8 +625,7 @@ are shared between the parent and child processes." ;; Some systems may be using an old (pre-2.14) version of glibc where there ;; is no 'setns' function available. (false-if-exception - (let* ((ptr (dynamic-func "setns" (dynamic-link))) - (proc (pointer->procedure int ptr (list int int)))) + (let ((proc (syscall->procedure int "setns" (list int int)))) (lambda (fdes nstype) "Reassociate the current process with the namespace specified by FDES, a file descriptor obtained by opening a /proc/PID/ns/* file. NSTYPE specifies @@ -818,9 +831,7 @@ bytevector BV at INDEX." (define %ioctl ;; The most terrible interface, live from Scheme. - (pointer->procedure int - (dynamic-func "ioctl" (dynamic-link)) - (list int unsigned-long '*))) + (syscall->procedure int "ioctl" (list int unsigned-long '*))) (define (bytevector->string-list bv stride len) "Return the null-terminated strings found in BV every STRIDE bytes. Read at @@ -1060,8 +1071,7 @@ return the list of resulting <interface> objects." (loop ptr (cons ifaddr result))))))) (define network-interfaces - (let* ((ptr (dynamic-func "getifaddrs" (dynamic-link))) - (proc (pointer->procedure int ptr (list '*)))) + (let ((proc (syscall->procedure int "getifaddrs" (list '*)))) (lambda () "Return a list of <interface> objects, each denoting a configured network interface. This is implemented using the 'getifaddrs' libc function." @@ -1078,8 +1088,7 @@ network interface. This is implemented using the 'getifaddrs' libc function." (list err))))))) (define free-ifaddrs - (let ((ptr (dynamic-func "freeifaddrs" (dynamic-link)))) - (pointer->procedure void ptr '(*)))) + (syscall->procedure void "freeifaddrs" '(*))) ;;; diff --git a/guix/gexp.scm b/guix/gexp.scm index b4d737ecae..2bf1013b3c 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -189,31 +189,21 @@ cross-compiling.)" ;; absolute file name. We keep it in a promise to compute it lazily and avoid ;; repeated 'stat' calls. (define-record-type <local-file> - (%%local-file file absolute name recursive?) + (%%local-file file absolute name recursive? select?) local-file? (file local-file-file) ;string (absolute %local-file-absolute-file-name) ;promise string (name local-file-name) ;string - (recursive? local-file-recursive?)) ;Boolean + (recursive? local-file-recursive?) ;Boolean + (select? local-file-select?)) ;string stat -> Boolean + +(define (true file stat) #t) (define* (%local-file file promise #:optional (name (basename file)) - #:key recursive?) + #:key recursive? (select? true)) ;; This intermediate procedure is part of our ABI, but the underlying ;; %%LOCAL-FILE is not. - (%%local-file file promise name recursive?)) - -(define (extract-directory properties) - "Extract the directory name from source location PROPERTIES." - (match (assq 'filename properties) - (('filename . (? string? file-name)) - (dirname file-name)) - (_ - #f))) - -(define-syntax-rule (current-source-directory) - "Expand to the directory of the current source file or #f if it could not -be determined." - (extract-directory (current-source-location))) + (%%local-file file promise name recursive? select?)) (define (absolute-file-name file directory) "Return the canonical absolute file name for FILE, which lives in the @@ -235,6 +225,10 @@ When RECURSIVE? is true, the contents of FILE are added recursively; if FILE designates a flat file and RECURSIVE? is true, its contents are added, and its permission bits are kept. +When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, +where FILE is the entry's absolute file name and STAT is the result of +'lstat'; exclude entries for which SELECT? does not return true. + This is the declarative counterpart of the 'interned-file' monadic procedure." (%local-file file (delay (absolute-file-name file (current-source-directory))) @@ -248,12 +242,13 @@ This is the declarative counterpart of the 'interned-file' monadic procedure." (define-gexp-compiler (local-file-compiler (file local-file?) system target) ;; "Compile" FILE by adding it to the store. (match file - (($ <local-file> file (= force absolute) name recursive?) + (($ <local-file> file (= force absolute) name recursive? select?) ;; Canonicalize FILE so that if it's a symlink, it is resolved. Failing ;; to do that, when RECURSIVE? is #t, we could end up creating a dangling ;; symlink in the store, and when RECURSIVE? is #f 'add-to-store' would ;; just throw an error, both of which are inconvenient. - (interned-file absolute name #:recursive? recursive?)))) + (interned-file absolute name + #:recursive? recursive? #:select? select?)))) (define-record-type <plain-file> (%plain-file name content references) diff --git a/guix/hg-download.scm b/guix/hg-download.scm new file mode 100644 index 0000000000..f3e1d2906a --- /dev/null +++ b/guix/hg-download.scm @@ -0,0 +1,84 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix hg-download) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix packages) + #:autoload (guix build-system gnu) (standard-packages) + #:use-module (ice-9 match) + #:export (hg-reference + hg-reference? + hg-reference-url + hg-reference-changeset + hg-reference-recursive? + + hg-fetch)) + +;;; Commentary: +;;; +;;; An <origin> method that fetches a specific changeset from a Mercurial +;;; repository. The repository URL and changeset ID are specified with a +;;; <hg-reference> object. +;;; +;;; Code: + +(define-record-type* <hg-reference> + hg-reference make-hg-reference + hg-reference? + (url hg-reference-url) + (changeset hg-reference-changeset)) + +(define (hg-package) + "Return the default Mercurial package." + (let ((distro (resolve-interface '(gnu packages version-control)))) + (module-ref distro 'mercurial))) + +(define* (hg-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile)) + (hg (hg-package))) + "Return a fixed-output derivation that fetches REF, a <hg-reference> +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." + (define build + #~(begin + (use-modules (guix build hg) + (guix build utils) + (ice-9 match)) + + (hg-fetch '#$(hg-reference-url ref) + '#$(hg-reference-changeset ref) + #$output + #:hg-command (string-append #+hg "/bin/hg")))) + + (mlet %store-monad ((guile (package->derivation guile system))) + (gexp->derivation (or name "hg-checkout") build + #:system system + #:local-build? #t ;don't offload repo cloning + #:hash-algo hash-algo + #:hash hash + #:recursive? #t + #:modules '((guix build hg) + (guix build utils)) + #:guile-for-build guile))) + +;;; hg-download.scm ends here diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index de30f4bea6..70ef507666 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -71,6 +71,16 @@ or #f on failure." (raise (condition (&missing-source-error (package pypi-package))))))) +(define (latest-wheel-release pypi-package) + "Return the url of the wheel for the latest release of pypi-package, +or #f if there isn't any." + (let ((releases (assoc-ref* pypi-package "releases" + (assoc-ref* pypi-package "info" "version")))) + (or (find (lambda (release) + (string=? "bdist_wheel" (assoc-ref release "packagetype"))) + releases) + #f))) + (define (python->package-name name) "Given the NAME of a package on PyPI, return a Guix-compliant name for the package." @@ -88,6 +98,11 @@ package on PyPI." ;; '/' + package name + '/' + ... (substring source-url 42 (string-rindex source-url #\/)))) +(define (wheel-url->extracted-directory wheel-url) + (match (string-split (basename wheel-url) #\-) + ((name version _ ...) + (string-append name "-" version ".dist-info")))) + (define (maybe-inputs package-inputs) "Given a list of PACKAGE-INPUTS, tries to generate the 'inputs' field of a package definition." @@ -97,10 +112,10 @@ package definition." ((package-inputs ...) `((inputs (,'quasiquote ,package-inputs)))))) -(define (guess-requirements source-url tarball) - "Given SOURCE-URL and a TARBALL of the package, return a list of the required -packages specified in the requirements.txt file. TARBALL will be extracted in -the current directory, and will be deleted." +(define (guess-requirements source-url wheel-url tarball) + "Given SOURCE-URL, WHEEL-URL and a TARBALL of the package, return a list of +the required packages specified in the requirements.txt file. TARBALL will be +extracted in the current directory, and will be deleted." (define (tarball-directory url) ;; Given the URL of the package's tarball, return the name of the directory @@ -147,26 +162,69 @@ cannot determine package dependencies")) (loop (cons (python->package-name (clean-requirement line)) result)))))))))) - (let ((dirname (tarball-directory source-url))) - (if (string? dirname) - (let* ((req-file (string-append dirname "/requirements.txt")) - (exit-code (system* "tar" "xf" tarball req-file))) - ;; TODO: support more formats. - (if (zero? exit-code) - (dynamic-wind - (const #t) - (lambda () - (read-requirements req-file)) - (lambda () - (delete-file req-file) - (rmdir dirname))) - (begin - (warning (_ "'tar xf' failed with exit code ~a\n") - exit-code) - '()))) - '()))) + (define (read-wheel-metadata wheel-archive) + ;; Given WHEEL-ARCHIVE, a ZIP Python wheel archive, return the package's + ;; requirements. + (let* ((dirname (wheel-url->extracted-directory wheel-url)) + (json-file (string-append dirname "/metadata.json"))) + (and (zero? (system* "unzip" "-q" wheel-archive json-file)) + (dynamic-wind + (const #t) + (lambda () + (call-with-input-file json-file + (lambda (port) + (let* ((metadata (json->scm port)) + (run_requires (hash-ref metadata "run_requires")) + (requirements (hash-ref (list-ref run_requires 0) + "requires"))) + (map (lambda (r) + (python->package-name (clean-requirement r))) + requirements))))) + (lambda () + (delete-file json-file) + (rmdir dirname)))))) + + (define (guess-requirements-from-wheel) + ;; Return the package's requirements using the wheel, or #f if an error + ;; occurs. + (call-with-temporary-output-file + (lambda (temp port) + (if wheel-url + (and (url-fetch wheel-url temp) + (read-wheel-metadata temp)) + #f)))) + + + (define (guess-requirements-from-source) + ;; Return the package's requirements by guessing them from the source. + (let ((dirname (tarball-directory source-url))) + (if (string? dirname) + (let* ((req-file (string-append dirname "/requirements.txt")) + (exit-code (system* "tar" "xf" tarball req-file))) + ;; TODO: support more formats. + (if (zero? exit-code) + (dynamic-wind + (const #t) + (lambda () + (read-requirements req-file)) + (lambda () + (delete-file req-file) + (rmdir dirname))) + (begin + (warning (_ "'tar xf' failed with exit code ~a\n") + exit-code) + '()))) + '()))) + + ;; First, try to compute the requirements using the wheel, since that is the + ;; most reliable option. If a wheel is not provided for this package, try + ;; getting them by reading the "requirements.txt" file from the source. Note + ;; that "requirements.txt" is not mandatory, so this is likely to fail. + (or (guess-requirements-from-wheel) + (guess-requirements-from-source))) + -(define (compute-inputs source-url tarball) +(define (compute-inputs source-url wheel-url tarball) "Given the SOURCE-URL of an already downloaded TARBALL, return a list of name/variable pairs describing the required inputs of this package." (sort @@ -175,13 +233,13 @@ name/variable pairs describing the required inputs of this package." (append '("python-setuptools") ;; Argparse has been part of Python since 2.7. (remove (cut string=? "python-argparse" <>) - (guess-requirements source-url tarball)))) + (guess-requirements source-url wheel-url tarball)))) (lambda args (match args (((a _ ...) (b _ ...)) (string-ci<? a b)))))) -(define (make-pypi-sexp name version source-url home-page synopsis +(define (make-pypi-sexp name version source-url wheel-url home-page synopsis description license) "Return the `package' s-expression for a python package with the given NAME, VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." @@ -206,7 +264,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (base32 ,(guix-hash-url temp))))) (build-system python-build-system) - ,@(maybe-inputs (compute-inputs source-url temp)) + ,@(maybe-inputs (compute-inputs source-url wheel-url temp)) (home-page ,home-page) (synopsis ,synopsis) (description ,description) @@ -225,11 +283,12 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (let ((name (assoc-ref* package "info" "name")) (version (assoc-ref* package "info" "version")) (release (assoc-ref (latest-source-release package) "url")) + (wheel (assoc-ref (latest-wheel-release package) "url")) (synopsis (assoc-ref* package "info" "summary")) (description (assoc-ref* package "info" "summary")) (home-page (assoc-ref* package "info" "home_page")) (license (string->license (assoc-ref* package "info" "license")))) - (make-pypi-sexp name version release home-page synopsis + (make-pypi-sexp name version release wheel home-page synopsis description license)))))) (define (pypi-package? package) diff --git a/guix/packages.scm b/guix/packages.scm index d62d1f3343..acb8f34417 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -406,6 +406,7 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." (define decompression-type (cond ((string-suffix? "gz" source-file-name) "gzip") + ((string-suffix? "Z" source-file-name) "gzip") ((string-suffix? "bz2" source-file-name) "bzip2") ((string-suffix? "lz" source-file-name) "lzip") ((string-suffix? "zip" source-file-name) "unzip") @@ -543,7 +544,8 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET." "--files-from=.file_list"))))))))) (let ((name (tarxz-name original-file-name)) - (modules (delete-duplicates (cons '(guix build utils) modules)))) + (modules (delete-duplicates (cons '(guix build utils) + imported-modules)))) (gexp->derivation name build #:graft? #f #:system system @@ -791,7 +793,7 @@ information in exceptions." ;; store path, it needs to be added anyway, so it can be used as a ;; source. (list name (intern file))) - (((? string? name) (? origin? source)) + (((? string? name) (? struct? source)) (list name (package-source-derivation store source system))) (x (raise (condition (&package-input-error @@ -1128,12 +1130,10 @@ cross-compilation target triplet." (package->cross-derivation package target system) (package->derivation package system))) -(define* (origin->derivation source +(define* (origin->derivation origin #:optional (system (%current-system))) - "When SOURCE is an <origin> object, return its derivation for SYSTEM. When -SOURCE is a file name, return either the interned file name (if SOURCE is -outside of the store) or SOURCE itself (if SOURCE is already a store item.)" - (match source + "Return the derivation corresponding to ORIGIN." + (match origin (($ <origin> uri method sha256 name (= force ()) #f) ;; No patches, no snippet: this is a fixed-output derivation. (method uri 'sha256 sha256 name #:system system)) @@ -1153,19 +1153,25 @@ outside of the store) or SOURCE itself (if SOURCE is already a store item.)" #:flags flags #:system system #:modules modules - #:imported-modules modules - #:guile-for-build guile))) - ((and (? string?) (? direct-store-path?) file) - (with-monad %store-monad - (return file))) - ((? string? file) - (interned-file file (basename file) - #:recursive? #t)))) + #:imported-modules imported-modules + #:guile-for-build guile))))) (define-gexp-compiler (origin-compiler (origin origin?) system target) ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring ;; to an origin from within a gexp. (origin->derivation origin system)) -(define package-source-derivation - (store-lower origin->derivation)) +(define package-source-derivation ;somewhat deprecated + (let ((lower (store-lower lower-object))) + (lambda* (store source #:optional (system (%current-system))) + "Return the derivation or file corresponding to SOURCE, which can be an +a file name or any object handled by 'lower-object', such as an <origin>. +When SOURCE is a file name, return either the interned file name (if SOURCE is +outside of the store) or SOURCE itself (if SOURCE is already a store item.)" + (match source + ((and (? string?) (? direct-store-path?) file) + file) + ((? string? file) + (add-to-store store (basename file) #t "sha256" file)) + (_ + (lower store source system)))))) diff --git a/guix/store.scm b/guix/store.scm index e3033ee61a..a64016611d 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -263,14 +263,12 @@ (path-info deriver hash refs registration-time nar-size))) (define-syntax write-arg - (syntax-rules (integer boolean file string string-list string-pairs + (syntax-rules (integer boolean string string-list string-pairs store-path store-path-list base16) ((_ integer arg p) (write-int arg p)) ((_ boolean arg p) (write-int (if arg 1 0) p)) - ((_ file arg p) - (write-file arg p)) ((_ string arg p) (write-string arg p)) ((_ string-list arg p) @@ -653,30 +651,51 @@ path." (hash-set! cache args path) path)))))) +(define true + ;; Define it once and for all since we use it as a default value for + ;; 'add-to-store' and want to make sure two default values are 'eq?' for the + ;; purposes or memoization. + (lambda (file stat) + #t)) + (define add-to-store ;; A memoizing version of `add-to-store'. This is important because ;; `add-to-store' leads to huge data transfers to the server, and ;; because it's often called many times with the very same argument. - (let ((add-to-store (operation (add-to-store (string basename) - (boolean fixed?) ; obsolete, must be #t - (boolean recursive?) - (string hash-algo) - (file file-name)) - #f - store-path))) - (lambda (server basename recursive? hash-algo file-name) + (let ((add-to-store + (lambda* (server basename recursive? hash-algo file-name + #:key (select? true)) + ;; We don't use the 'operation' macro so we can pass SELECT? to + ;; 'write-file'. + (let ((port (nix-server-socket server))) + (write-int (operation-id add-to-store) port) + (write-string basename port) + (write-int 1 port) ;obsolete, must be #t + (write-int (if recursive? 1 0) port) + (write-string hash-algo port) + (write-file file-name port #:select? select?) + (let loop ((done? (process-stderr server))) + (or done? (loop (process-stderr server)))) + (read-store-path port))))) + (lambda* (server basename recursive? hash-algo file-name + #:key (select? true)) "Add the contents of FILE-NAME under BASENAME to the store. When RECURSIVE? is false, FILE-NAME must designate a regular file--not a directory nor a symlink. When RECURSIVE? is true and FILE-NAME designates a directory, the contents of FILE-NAME are added recursively; if FILE-NAME designates a flat file and RECURSIVE? is true, its contents are added, and its permission -bits are kept. HASH-ALGO must be a string such as \"sha256\"." +bits are kept. HASH-ALGO must be a string such as \"sha256\". + +When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, +where FILE is the entry's absolute file name and STAT is the result of +'lstat'; exclude entries for which SELECT? does not return true." (let* ((st (false-if-exception (lstat file-name))) - (args `(,st ,basename ,recursive? ,hash-algo)) + (args `(,st ,basename ,recursive? ,hash-algo ,select?)) (cache (nix-server-add-to-store-cache server))) (or (and st (hash-ref cache args)) - (let ((path (add-to-store server basename #t recursive? - hash-algo file-name))) + (let ((path (add-to-store server basename recursive? + hash-algo file-name + #:select? select?))) (hash-set! cache args path) path)))))) @@ -1111,16 +1130,21 @@ resulting text file refers to; it defaults to the empty list." store))) (define* (interned-file file #:optional name - #:key (recursive? #t)) + #:key (recursive? #t) (select? true)) "Return the name of FILE once interned in the store. Use NAME as its store name, or the basename of FILE if NAME is omitted. When RECURSIVE? is true, the contents of FILE are added recursively; if FILE designates a flat file and RECURSIVE? is true, its contents are added, and its -permission bits are kept." +permission bits are kept. + +When RECURSIVE? is true, call (SELECT? FILE STAT) for each directory entry, +where FILE is the entry's absolute file name and STAT is the result of +'lstat'; exclude entries for which SELECT? does not return true." (lambda (store) (values (add-to-store store (or name (basename file)) - recursive? "sha256" file) + recursive? "sha256" file + #:select? select?) store))) (define build diff --git a/guix/utils.scm b/guix/utils.scm index c77da5d846..a642bd3d62 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -34,7 +34,7 @@ #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix combinators) #:use-module ((guix build utils) #:select (dump-port)) - #:use-module ((guix build syscalls) #:select (mkdtemp!)) + #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:autoload (ice-9 popen) (open-pipe*) @@ -53,6 +53,8 @@ substitute-keyword-arguments ensure-keyword-arguments + current-source-directory + <location> location location? @@ -625,11 +627,13 @@ output port, and PROC's result is returned." (with-throw-handler #t (lambda () (let ((result (proc out))) - (close out) + (fdatasync out) + (close-port out) (rename-file template file) result)) (lambda (key . args) - (false-if-exception (delete-file template)))))) + (false-if-exception (delete-file template)) + (close-port out))))) (define (cache-directory) "Return the cache directory for Guix, by default ~/.cache/guix." @@ -698,6 +702,23 @@ output port, and PROC's result is returned." ;;; Source location. ;;; +(define-syntax current-source-directory + (lambda (s) + "Return the absolute name of the current directory, or #f if it could not +be determined." + (syntax-case s () + ((_) + (match (assq 'filename (syntax-source s)) + (('filename . (? string? file-name)) + ;; If %FILE-PORT-NAME-CANONICALIZATION is 'relative, then FILE-NAME + ;; can be relative. In that case, we try to find out the absolute + ;; file name by looking at %LOAD-PATH. + (if (string-prefix? "/" file-name) + (dirname file-name) + (and=> (search-path %load-path file-name) dirname))) + (_ + #f)))))) + ;; A source location. (define-record-type <location> (make-location file line column) |