From 122c87ead0452a3042f1d42db9986a41218732cf Mon Sep 17 00:00:00 2001 From: Taylan Ulrich Bayırlı/Kammer Date: Thu, 26 Mar 2015 23:34:21 +0100 Subject: Fix remaining references to "substitute-binary". * nix/nix-daemon/guix-daemon.cc (main): Change substitute-binary to substitute. * po/guix/POTFILES.in: Likewise. * tests/guix-daemon.sh: Likewise. * tests/guix-system.sh: Likewise. --- tests/guix-daemon.sh | 4 ++-- tests/guix-system.sh | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'tests') diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index a73c9e22e3..87f17def12 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -17,7 +17,7 @@ # along with GNU Guix. If not, see . # -# Test the daemon and its interaction with 'guix substitute-binary'. +# Test the daemon and its interaction with 'guix substitute'. # set -e @@ -51,7 +51,7 @@ Deriver: $drv EOF # Remove the cached narinfo. -rm -f "$XDG_CACHE_HOME/guix/substitute-binary/$hash_part" +rm -f "$XDG_CACHE_HOME/guix/substitute/$hash_part" # Make sure we see the substitute. guile -c ' diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 76e722fbc1..1b77d1a0db 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -17,7 +17,7 @@ # along with GNU Guix. If not, see . # -# Test the daemon and its interaction with 'guix substitute-binary'. +# Test the daemon and its interaction with 'guix substitute'. # set -e -- cgit v1.2.3 From d9ae938f2c950f3bf1896fb07189c3e28b4d8029 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Mar 2015 21:26:33 +0100 Subject: gexp: Add 'local-file'. * guix/gexp.scm (): New record type. (local-file): New procedure. (local-file-compiler): New compiler. (gexp->sexp) : Handle the case where 'lower' returns a file name. (text-file*): Update docstring.local-file doc * tests/gexp.scm ("one local file", "gexp->derivation, local-file"): New tests. * doc/guix.texi (G-Expressions): Mention local files early. Document 'local-file'. Update 'text-file*' documentation. --- doc/guix.texi | 24 +++++++++++++++++++++--- guix/gexp.scm | 47 +++++++++++++++++++++++++++++++++++++++++++---- tests/gexp.scm | 26 ++++++++++++++++++++++++++ 3 files changed, 90 insertions(+), 7 deletions(-) (limited to 'tests') diff --git a/doc/guix.texi b/doc/guix.texi index 18e6733083..4e549ac2ef 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2503,7 +2503,10 @@ processes that use them. Actually this mechanism is not limited to package and derivation objects; @dfn{compilers} able to ``lower'' other high-level objects to derivations can be defined, such that these objects can also be inserted -into gexps. +into gexps. Another useful type of high-level object that can be +inserted in a gexp is @dfn{local files}, which allows files from the +local file system to be added to the store and referred to by +derivations and such (see @code{local-file} below.) To illustrate the idea, here is an example of a gexp: @@ -2666,6 +2669,20 @@ refer to. Any reference to another store item will lead to a build error. The other arguments are as for @code{derivation} (@pxref{Derivations}). @end deffn +@deffn {Scheme Procedure} local-file @var{file} [@var{name}] @ + [#:recursive? #t] +Return an object representing local file @var{file} to add to the store; this +object can be used in a gexp. @var{file} will be added to the store under @var{name}--by +default the base name of @var{file}. + +When @var{recursive?} is true, the contents of @var{file} are added recursively; if @var{file} +designates a flat file and @var{recursive?} is true, its contents are added, and its +permission bits are kept. + +This is the declarative counterpart of the @code{interned-file} monadic +procedure (@pxref{The Store Monad, @code{interned-file}}). +@end deffn + @deffn {Monadic Procedure} gexp->script @var{name} @var{exp} Return an executable script @var{name} that runs @var{exp} using @var{guile} with @var{modules} in its search path. @@ -2703,8 +2720,9 @@ or a subset thereof. @deffn {Monadic Procedure} text-file* @var{name} @var{text} @dots{} Return as a monadic value a derivation that builds a text file containing all of @var{text}. @var{text} may list, in addition to -strings, packages, derivations, and store file names; the resulting -store file holds references to all these. +strings, objects of any type that can be used in a gexp: packages, +derivations, local file objects, etc. The resulting store file holds +references to all these. This variant should be preferred over @code{text-file} anytime the file to create will reference items from the store. This is typically the diff --git a/guix/gexp.scm b/guix/gexp.scm index 01290dba18..2492974d8f 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -31,6 +31,8 @@ gexp-input gexp-input? + local-file + local-file? gexp->derivation gexp->file @@ -133,6 +135,37 @@ cross-compiling.)" (with-monad %store-monad (return drv))) + +;;; +;;; Local files. +;;; + +(define-record-type + (%local-file file name recursive?) + local-file? + (file local-file-file) ;string + (name local-file-name) ;string + (recursive? local-file-recursive?)) ;Boolean + +(define* (local-file file #:optional (name (basename file)) + #:key (recursive? #t)) + "Return an object representing local file FILE to add to the store; this +object can be used in a gexp. FILE will be added to the store under NAME--by +default the base name of FILE. + +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. + +This is the declarative counterpart of the 'interned-file' monadic procedure." + (%local-file file name recursive?)) + +(define-gexp-compiler (local-file-compiler (file local-file?) system target) + ;; "Compile" FILE by adding it to the store. + (match file + (($ file name recursive?) + (interned-file file name #:recursive? recursive?)))) + ;;; ;;; Inputs & outputs. @@ -453,8 +486,13 @@ and in the current monad setting (system type, etc.)" (($ (? struct? thing) output n?) (let ((lower (lookup-compiler thing)) (target (if (or n? native?) #f target))) - (mlet %store-monad ((drv (lower thing system target))) - (return (derivation->output-path drv output))))) + (mlet %store-monad ((obj (lower thing system target))) + ;; OBJ must be either a derivation or a store file name. + (return (match obj + ((? derivation? drv) + (derivation->output-path drv output)) + ((? string? file) + file)))))) (($ x) (return x)) (x @@ -809,8 +847,9 @@ its search path." (define* (text-file* name #:rest text) "Return as a monadic value a derivation that builds a text file containing -all of TEXT. TEXT may list, in addition to strings, packages, derivations, -and store file names; the resulting store file holds references to all these." +all of TEXT. TEXT may list, in addition to strings, objects of any type that +can be used in a gexp: packages, derivations, local file objects, etc. The +resulting store file holds references to all these." (define builder (gexp (call-with-output-file (ungexp output "out") (lambda (port) diff --git a/tests/gexp.scm b/tests/gexp.scm index 0540969503..f81ef39860 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -97,6 +97,18 @@ %store (package-source coreutils)))) (gexp->sexp* exp))))) +(test-assert "one local file" + (let* ((file (search-path %load-path "guix.scm")) + (local (local-file file)) + (exp (gexp (display (ungexp local)))) + (intd (add-to-store %store (basename file) #t + "sha256" file))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((x "out")) + (eq? x local))) + (equal? `(display ,intd) (gexp->sexp* exp))))) + (test-assert "same input twice" (let ((exp (gexp (begin (display (ungexp coreutils)) @@ -336,6 +348,20 @@ (mlet %store-monad ((drv mdrv)) (return (string=? system (derivation-system drv)))))) +(test-assertm "gexp->derivation, local-file" + (mlet* %store-monad ((file -> (search-path %load-path "guix.scm")) + (intd (interned-file file)) + (local -> (local-file file)) + (exp -> (gexp (begin + (stat (ungexp local)) + (symlink (ungexp local) + (ungexp output))))) + (drv (gexp->derivation "local-file" exp))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (string=? (readlink (derivation->output-path drv)) + intd))))) + (test-assertm "gexp->derivation, cross-compilation" (mlet* %store-monad ((target -> "mips64el-linux") (exp -> (gexp (list (ungexp coreutils) -- cgit v1.2.3 From 4e7b6b4838318ca127ae588a7a28c8608b0c8721 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 31 Mar 2015 21:59:05 +0200 Subject: tests: Fix module name for 'lint'. * tests/lint.scm: Change module name to 'test-lint'. --- tests/lint.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/lint.scm b/tests/lint.scm index c0599224b7..2312b80934 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -18,8 +18,7 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . - -(define-module (test-packages) +(define-module (test-lint) #:use-module (guix tests) #:use-module (guix download) #:use-module (guix build-system gnu) -- cgit v1.2.3 From 15aa2c38429a5785ed08519c88ff89a0b7027f0f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 31 Mar 2015 22:10:08 +0200 Subject: Add (guix build gremlin). * guix/build/gremlin.scm, tests/gremlin.scm: New files. * Makefile.am (MODULES): Add guix/build/gremlin.scm. (SCM_TESTS): Add tests/gremlin.scm. --- Makefile.am | 2 + guix/build/gremlin.scm | 236 +++++++++++++++++++++++++++++++++++++++++++++++++ tests/gremlin.scm | 57 ++++++++++++ 3 files changed, 295 insertions(+) create mode 100644 guix/build/gremlin.scm create mode 100644 tests/gremlin.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index 4a1f8d0a88..cf709986ed 100644 --- a/Makefile.am +++ b/Makefile.am @@ -82,6 +82,7 @@ MODULES = \ guix/build/cvs.scm \ guix/build/svn.scm \ guix/build/syscalls.scm \ + guix/build/gremlin.scm \ guix/build/emacs-utils.scm \ guix/build/graft.scm \ guix/packages.scm \ @@ -178,6 +179,7 @@ SCM_TESTS = \ tests/union.scm \ tests/profiles.scm \ tests/syscalls.scm \ + tests/gremlin.scm \ tests/lint.scm if HAVE_GUILE_JSON diff --git a/guix/build/gremlin.scm b/guix/build/gremlin.scm new file mode 100644 index 0000000000..e8429129e1 --- /dev/null +++ b/guix/build/gremlin.scm @@ -0,0 +1,236 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 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 build gremlin) + #:use-module (guix elf) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:export (elf-dynamic-info + elf-dynamic-info? + elf-dynamic-info-sopath + elf-dynamic-info-needed + elf-dynamic-info-rpath + elf-dynamic-info-runpath + + validate-needed-in-runpath)) + +;;; Commentary: +;;; +;;; A gremlin is sort-of like an elf, you know, and this module provides tools +;;; to deal with dynamic-link information from ELF files. +;;; +;;; Code: + +(define (dynamic-link-segment elf) + "Return the 'PT_DYNAMIC' segment of ELF--i.e., the segment that contains +dynamic linking information." + (find (lambda (segment) + (= (elf-segment-type segment) PT_DYNAMIC)) + (elf-segments elf))) + +(define (word-reader size byte-order) + "Return a procedure to read a word of SIZE bytes according to BYTE-ORDER." + (case size + ((8) + (lambda (bv index) + (bytevector-u64-ref bv index byte-order))) + ((4) + (lambda (bv index) + (bytevector-u32-ref bv index byte-order))))) + + +;; Dynamic entry: +;; +;; typedef struct +;; { +;; Elf64_Sxword d_tag; /* Dynamic entry type */ +;; union +;; { +;; Elf64_Xword d_val; /* Integer value */ +;; Elf64_Addr d_ptr; /* Address value */ +;; } d_un; +;; } Elf64_Dyn; + +(define (raw-dynamic-entries elf segment) + "Return as a list of type/value pairs all the dynamic entries found in +SEGMENT, the 'PT_DYNAMIC' segment of ELF. In the result, each car is a DT_ +value, and the interpretation of the cdr depends on the type." + (define start + (elf-segment-offset segment)) + (define bytes + (elf-bytes elf)) + (define word-size + (elf-word-size elf)) + (define byte-order + (elf-byte-order elf)) + (define read-word + (word-reader word-size byte-order)) + + (let loop ((offset 0) + (result '())) + (if (>= offset (elf-segment-memsz segment)) + (reverse result) + (let ((type (read-word bytes (+ start offset))) + (value (read-word bytes (+ start offset word-size)))) + (if (= type DT_NULL) ;finished? + (reverse result) + (loop (+ offset (* 2 word-size)) + (alist-cons type value result))))))) + +(define (vma->offset elf vma) + "Convert VMA, a virtual memory address, to an offset within ELF. + +Do that by looking at the loadable program segment (PT_LOAD) of ELF that +contains VMA and by taking into account that segment's virtual address and +offset." + ;; See 'offset_from_vma' in Binutils. + (define loads + (filter (lambda (segment) + (= (elf-segment-type segment) PT_LOAD)) + (elf-segments elf))) + + (let ((load (find (lambda (segment) + (let ((vaddr (elf-segment-vaddr segment))) + (and (>= vma vaddr) + (< vma (+ (elf-segment-memsz segment) + vaddr))))) + loads))) + (+ (- vma (elf-segment-vaddr load)) + (elf-segment-offset load)))) + +(define (dynamic-entries elf segment) + "Return all the dynamic entries found in SEGMENT, the 'PT_DYNAMIC' segment +of ELF, as a list of type/value pairs. The type is a DT_ value, and the value +may be a string or an integer depending on the entry type (for instance, the +value of DT_NEEDED entries is a string.)" + (define entries + (raw-dynamic-entries elf segment)) + + (define string-table-offset + (any (match-lambda + ((type . value) + (and (= type DT_STRTAB) value)) + (_ #f)) + entries)) + + (define (interpret-dynamic-entry type value) + (cond ((memv type (list DT_NEEDED DT_SONAME DT_RPATH DT_RUNPATH)) + (if string-table-offset + (pointer->string + (bytevector->pointer (elf-bytes elf) + (vma->offset + elf + (+ string-table-offset value)))) + value)) + (else + value))) + + (map (match-lambda + ((type . value) + (cons type (interpret-dynamic-entry type value)))) + entries)) + + +;;; +;;; High-level interface. +;;; + +(define-record-type + (%elf-dynamic-info soname needed rpath runpath) + elf-dynamic-info? + (soname elf-dynamic-info-soname) + (needed elf-dynamic-info-needed) + (rpath elf-dynamic-info-rpath) + (runpath elf-dynamic-info-runpath)) + +(define search-path->list + (let ((not-colon (char-set-complement (char-set #\:)))) + (lambda (str) + "Split STR on ':' characters." + (string-tokenize str not-colon)))) + +(define (elf-dynamic-info elf) + "Return dynamic-link information for ELF as an object, or +#f if ELF lacks dynamic-link information." + (match (dynamic-link-segment elf) + (#f #f) + ((? elf-segment? dynamic) + (let ((entries (dynamic-entries elf dynamic))) + (%elf-dynamic-info (assv-ref entries DT_SONAME) + (filter-map (match-lambda + ((type . value) + (and (= type DT_NEEDED) value)) + (_ #f)) + entries) + (or (and=> (assv-ref entries DT_RPATH) + search-path->list) + '()) + (or (and=> (assv-ref entries DT_RUNPATH) + search-path->list) + '())))))) + +(define %libc-libraries + ;; List of libraries as of glibc 2.21 (there are more but those are + ;; typically mean to be LD_PRELOADed and thus do not appear as NEEDED.) + '("libanl.so" + "libcrypt.so" + "libc.so" + "libdl.so" + "libm.so" + "libpthread.so" + "libresolv.so" + "librt.so" + "libutil.so")) + +(define (libc-library? lib) + "Return #t if LIB is one of the libraries shipped with the GNU C Library." + (find (lambda (libc-lib) + (string-prefix? libc-lib lib)) + %libc-libraries)) + +(define* (validate-needed-in-runpath file + #:key (always-found? libc-library?)) + "Return #t if all the libraries listed as FILE's 'DT_NEEDED' entries are +present in its RUNPATH, or if FILE lacks dynamic-link information. Return #f +otherwise. Libraries whose name matches ALWAYS-FOUND? are considered to be +always available." + (let* ((elf (call-with-input-file file + (compose parse-elf get-bytevector-all))) + (dyninfo (elf-dynamic-info elf))) + (when dyninfo + (let* ((runpath (elf-dynamic-info-runpath dyninfo)) + (needed (remove always-found? + (elf-dynamic-info-needed dyninfo))) + (not-found (remove (cut search-path runpath <>) + needed))) + (for-each (lambda (lib) + (format (current-error-port) + "error: '~a' depends on '~a', which cannot \ +be found in RUNPATH ~s~%" + file lib runpath)) + not-found) + ;; (when (null? not-found) + ;; (format (current-error-port) "~a is OK~%" file)) + (null? not-found))))) + +;;; gremlin.scm ends here diff --git a/tests/gremlin.scm b/tests/gremlin.scm new file mode 100644 index 0000000000..225a72ff9f --- /dev/null +++ b/tests/gremlin.scm @@ -0,0 +1,57 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 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-gremlin) + #:use-module (guix elf) + #:use-module (guix build utils) + #:use-module (guix build gremlin) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (rnrs io ports) + #:use-module (ice-9 match)) + +(define %guile-executable + (match (command-line) + ((program . _) + (and (file-exists? program) (elf-file? program) + program)) + (_ + #f))) + +(define read-elf + (compose parse-elf get-bytevector-all)) + + +(test-begin "gremlin") + +(unless %guile-executable (test-skip 1)) +(test-assert "elf-dynamic-info-needed, executable" + (let* ((elf (call-with-input-file %guile-executable read-elf)) + (dyninfo (elf-dynamic-info elf))) + (or (not dyninfo) ;static executable + (lset<= string=? + (list (string-append "libguile-" (effective-version)) + "libgc" "libunistring" "libffi") + (map (lambda (lib) + (string-take lib (string-contains lib ".so"))) + (elf-dynamic-info-needed dyninfo)))))) + +(test-end "gremlin") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3