Merge branch 'master' into core-updates
This commit is contained in:
Ludovic Courtès
commit
0562dbe5d3
|
|
@ -345,6 +345,9 @@ A number of optional fields may be specified:
|
|||
|
||||
@table @code
|
||||
|
||||
@item port
|
||||
Port number of the machine's SSH server (default: 22).
|
||||
|
||||
@item private-key
|
||||
The SSH private key file to use when connecting to the machine.
|
||||
|
||||
|
|
@ -1840,6 +1843,34 @@ Cross-build for @var{triplet}, which must be a valid GNU triplet, such
|
|||
as @code{"mips64el-linux-gnu"} (@pxref{Configuration Names, GNU
|
||||
configuration triplets,, configure, GNU Configure and Build System}).
|
||||
|
||||
@item --with-source=@var{source}
|
||||
Use @var{source} as the source of the corresponding package.
|
||||
@var{source} must be a file name or a URL, as for @command{guix
|
||||
download} (@pxref{Invoking guix download}).
|
||||
|
||||
The ``corresponding package'' is taken to be one specified on the
|
||||
command line whose name matches the base of @var{source}---e.g., if
|
||||
@var{source} is @code{/src/guile-2.0.10.tar.gz}, the corresponding
|
||||
package is @code{guile}. Likewise, the version string is inferred from
|
||||
@var{source}; in the previous example, it's @code{2.0.10}.
|
||||
|
||||
This option allows users to try out versions of packages other than the
|
||||
one provided by the distribution. The example below downloads
|
||||
@file{ed-1.7.tar.gz} from a GNU mirror and uses that as the source for
|
||||
the @code{ed} package:
|
||||
|
||||
@example
|
||||
guix build ed --with-source=mirror://gnu/ed/ed-1.7.tar.gz
|
||||
@end example
|
||||
|
||||
As a developer, @code{--with-source} makes it easy to test release
|
||||
candidates:
|
||||
|
||||
@example
|
||||
guix build guile --with-source=../guile-2.0.9.219-e1bb7.tar.xz
|
||||
@end example
|
||||
|
||||
|
||||
@item --derivations
|
||||
@itemx -d
|
||||
Return the derivation paths, not the output paths, of the given
|
||||
|
|
|
|||
|
|
@ -310,8 +310,6 @@ dist_patch_DATA = \
|
|||
gnu/packages/patches/perl-no-sys-dirs.patch \
|
||||
gnu/packages/patches/plotutils-libpng-jmpbuf.patch \
|
||||
gnu/packages/patches/procps-make-3.82.patch \
|
||||
gnu/packages/patches/pulseaudio-test-timeouts.patch \
|
||||
gnu/packages/patches/pulseaudio-volume-test.patch \
|
||||
gnu/packages/patches/python-fix-dbm.patch \
|
||||
gnu/packages/patches/qemu-make-4.0.patch \
|
||||
gnu/packages/patches/qemu-multiple-smb-shares.patch \
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -186,7 +186,7 @@ where the OS part is overloaded to denote a specific ABI---into GCC
|
|||
'configure 'post-configure
|
||||
(lambda _
|
||||
;; Don't store configure flags, to avoid retaining references to
|
||||
;; build-time dependencies---e.g., `--with-ppl=/nix/store/xxx'.
|
||||
;; build-time dependencies---e.g., `--with-ppl=/gnu/store/xxx'.
|
||||
(substitute* "Makefile"
|
||||
(("^TOPLEVEL_CONFIGURE_ARGUMENTS=(.*)$" _ rest)
|
||||
"TOPLEVEL_CONFIGURE_ARGUMENTS=\n")))
|
||||
|
|
|
|||
|
|
@ -29,36 +29,26 @@
|
|||
(define-public guile-xcb
|
||||
(package
|
||||
(name "guile-xcb")
|
||||
(version "1.2")
|
||||
(version "1.3")
|
||||
(source (origin
|
||||
(method url-fetch)
|
||||
(uri (string-append "http://www.markwitmer.com/dist/guile-xcb-"
|
||||
version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"009qrw46ay74z3mw8gz7jqvn90z9ilyhy00801w5vpyias02730y"))))
|
||||
"04dvbqdrrs67490gn4gkq9zk8mqy3mkls2818ha4p0ckhh0pm149"))))
|
||||
(build-system gnu-build-system)
|
||||
(arguments '(;; Parallel builds fail.
|
||||
#:parallel-build? #f
|
||||
|
||||
;; The '.scm' files go to $(datadir), so set that to the
|
||||
;; standard value.
|
||||
#:configure-flags (list (string-append
|
||||
"--datadir="
|
||||
"--with-guile-site-dir="
|
||||
(assoc-ref %outputs "out")
|
||||
"/share/guile/site/2.0"))
|
||||
#:phases (alist-cons-before
|
||||
'configure 'set-go-directory
|
||||
(lambda* (#:key outputs #:allow-other-keys)
|
||||
;; The makefile sets the .go directory to Guile's
|
||||
;; own .go site directory, which is read-only.
|
||||
;; Change it to point to $out/share/guile/site/2.0.
|
||||
(let ((out (assoc-ref outputs "out")))
|
||||
(substitute* "Makefile.in"
|
||||
(("^godir = .*$")
|
||||
(string-append "godir = " out
|
||||
"/share/guile/site/2.0\n")))))
|
||||
%standard-phases)))
|
||||
"/share/guile/site/2.0")
|
||||
(string-append
|
||||
"--with-guile-site-ccache-dir="
|
||||
(assoc-ref %outputs "out")
|
||||
"/share/guile/site/2.0"))))
|
||||
(native-inputs `(("pkg-config" ,pkg-config)))
|
||||
(inputs `(("guile" ,guile-2.0)
|
||||
("xcb" ,xcb-proto)))
|
||||
|
|
|
|||
|
|
@ -165,6 +165,8 @@
|
|||
(substitute* ".config"
|
||||
(("^# CONFIG_CIFS.*$")
|
||||
"CONFIG_CIFS=m\n")
|
||||
(("^# CONFIG_FUSE_FS.*$")
|
||||
"CONFIG_FUSE_FS=m\n")
|
||||
(("^# CONFIG_([[:graph:]]*)VIRTIO([[:graph:]]*) .*$"
|
||||
_ before after)
|
||||
(string-append "CONFIG_" before "VIRTIO"
|
||||
|
|
@ -899,7 +901,7 @@ processes currently causing I/O.")
|
|||
(base32
|
||||
"071r6xjgssy8vwdn6m28qq1bqxsd2bphcd2mzhq0grf5ybm87sqb"))))
|
||||
(build-system gnu-build-system)
|
||||
(native-inputs `(("util-linux" ,util-linux)))
|
||||
(inputs `(("util-linux" ,util-linux)))
|
||||
(arguments
|
||||
'(#:configure-flags (list (string-append "MOUNT_FUSE_PATH="
|
||||
(assoc-ref %outputs "out")
|
||||
|
|
@ -909,7 +911,20 @@ processes currently causing I/O.")
|
|||
"/etc/init.d")
|
||||
(string-append "UDEV_RULES_PATH="
|
||||
(assoc-ref %outputs "out")
|
||||
"/etc/udev"))))
|
||||
"/etc/udev"))
|
||||
#:phases (alist-cons-before
|
||||
'build 'set-file-names
|
||||
(lambda* (#:key inputs #:allow-other-keys)
|
||||
;; libfuse calls out to mount(8) and umount(8). Make sure
|
||||
;; it refers to the right ones.
|
||||
(substitute* '("lib/mount_util.c" "util/mount_util.c")
|
||||
(("/bin/(u?)mount" _ maybe-u)
|
||||
(string-append (assoc-ref inputs "util-linux")
|
||||
"/bin/" maybe-u "mount")))
|
||||
(substitute* '("util/mount.fuse.c")
|
||||
(("/bin/sh")
|
||||
(which "sh"))))
|
||||
%standard-phases)))
|
||||
(home-page "http://fuse.sourceforge.net/")
|
||||
(synopsis "Support file systems implemented in user space")
|
||||
(description
|
||||
|
|
@ -945,3 +960,19 @@ space, using the FUSE library. Mounting a union file system allows you to
|
|||
\"aggregate\" the contents of several directories into a single mount point.
|
||||
UnionFS-FUSE additionally supports copy-on-write.")
|
||||
(license bsd-3)))
|
||||
|
||||
(define-public unionfs-fuse/static
|
||||
(package (inherit unionfs-fuse)
|
||||
(synopsis "User-space union file system (statically linked)")
|
||||
(name (string-append (package-name unionfs-fuse) "-static"))
|
||||
(source (origin (inherit (package-source unionfs-fuse))
|
||||
(modules '((guix build utils)))
|
||||
(snippet
|
||||
;; Add -ldl to the libraries, because libfuse.a needs that.
|
||||
'(substitute* "src/CMakeLists.txt"
|
||||
(("target_link_libraries(.*)\\)" _ libs)
|
||||
(string-append "target_link_libraries"
|
||||
libs " dl)"))))))
|
||||
(arguments
|
||||
'(#:tests? #f
|
||||
#:configure-flags '("-DCMAKE_EXE_LINKER_FLAGS=-static")))))
|
||||
|
|
|
|||
|
|
@ -1,19 +0,0 @@
|
|||
Increase the timeout of the thread test. Hydra was intermittedly
|
||||
failing this test due to premature timeout, and slower machines
|
||||
consistently fail.
|
||||
|
||||
Patch by Mark H Weaver <mhw@netris.org>.
|
||||
|
||||
--- pulseaudio/src/tests/thread-test.c.orig 2012-09-26 07:27:01.000000000 -0400
|
||||
+++ pulseaudio/src/tests/thread-test.c 2013-10-31 22:53:23.224000184 -0400
|
||||
@@ -152,6 +152,10 @@
|
||||
s = suite_create("Thread");
|
||||
tc = tcase_create("thread");
|
||||
tcase_add_test(tc, thread_test);
|
||||
+ /* the default timeout is too small,
|
||||
+ * set it to a reasonable large one.
|
||||
+ */
|
||||
+ tcase_set_timeout(tc, 60 * 60);
|
||||
suite_add_tcase(s, tc);
|
||||
|
||||
sr = srunner_create(s);
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
Fix seemingly random failures of 'volume-test' in particular on 32-bit
|
||||
machines. See <https://bugs.freedesktop.org/show_bug.cgi?id=72374> for
|
||||
details.
|
||||
|
||||
From 27e47c72a25846e107b6e450c3a1480a2742382e Mon Sep 17 00:00:00 2001
|
||||
From: Tanu Kaskinen <tanu.kaskinen@linux.intel.com>
|
||||
Date: Sat, 14 Dec 2013 07:21:22 +0000
|
||||
Subject: volume-test: Increase the allowed number of rouding errors
|
||||
|
||||
BugLink: https://bugs.freedesktop.org/show_bug.cgi?id=72374
|
||||
---
|
||||
diff --git a/src/tests/volume-test.c b/src/tests/volume-test.c
|
||||
index a2daf3e..1ab0b5c 100644
|
||||
--- a/src/tests/volume-test.c
|
||||
+++ b/src/tests/volume-test.c
|
||||
@@ -138,7 +138,13 @@ START_TEST (volume_test) {
|
||||
pa_log("max deviation: %lu n=%lu", (unsigned long) md, (unsigned long) mdn);
|
||||
|
||||
fail_unless(md <= 1);
|
||||
- fail_unless(mdn <= 251);
|
||||
+
|
||||
+ /* mdn counts the times there were rounding errors during the test. The
|
||||
+ * number of rounding errors seems to vary slightly depending on the
|
||||
+ * hardware. The original limit was 251 errors, but it was increased to 253
|
||||
+ * when the test was failing on Tanu's laptop.
|
||||
+ * See https://bugs.freedesktop.org/show_bug.cgi?id=72374 */
|
||||
+ fail_unless(mdn <= 253);
|
||||
}
|
||||
END_TEST
|
||||
|
|
@ -134,7 +134,7 @@ parse JSON formatted strings back into the C representation of JSON objects.")
|
|||
(define pulseaudio
|
||||
(package
|
||||
(name "pulseaudio")
|
||||
(version "4.0")
|
||||
(version "5.0")
|
||||
(source (origin
|
||||
(method url-fetch)
|
||||
(uri (string-append
|
||||
|
|
@ -142,10 +142,7 @@ parse JSON formatted strings back into the C representation of JSON objects.")
|
|||
version ".tar.xz"))
|
||||
(sha256
|
||||
(base32
|
||||
"1bndz4l8jxyq3zq128gzp3gryxl6yjs66j2y1d7yabw2n5mv7kim"))
|
||||
(patches (map search-patch
|
||||
'("pulseaudio-test-timeouts.patch"
|
||||
"pulseaudio-volume-test.patch")))))
|
||||
"0fgrr8v7yfh0byhzdv4c87v9lkj8g7gpjm8r9xrbvpa92a5kmhcr"))))
|
||||
(build-system gnu-build-system)
|
||||
(arguments
|
||||
`(#:configure-flags '("--localstatedir=/var" ;"--sysconfdir=/etc"
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@
|
|||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
(uri (string-append "http://www.python.org/ftp/python/"
|
||||
(uri (string-append "https://www.python.org/ftp/python/"
|
||||
version "/Python-" version ".tar.xz"))
|
||||
(sha256
|
||||
(base32
|
||||
|
|
@ -165,7 +165,7 @@ data types.")
|
|||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
(uri (string-append "http://www.python.org/ftp/python/"
|
||||
(uri (string-append "https://www.python.org/ftp/python/"
|
||||
version "/Python-" version ".tar.xz"))
|
||||
(sha256
|
||||
(base32
|
||||
|
|
|
|||
|
|
@ -373,7 +373,7 @@ such as /etc files."
|
|||
;; (not 'futime'), so the timestamp of
|
||||
;; symlinks cannot be changed, and there
|
||||
;; are symlinks here pointing to
|
||||
;; /nix/store, which is the host,
|
||||
;; /gnu/store, which is the host,
|
||||
;; read-only store.
|
||||
(unless (eq? (stat:type s) 'symlink)
|
||||
(utime file 0 0 0 0))))
|
||||
|
|
@ -448,7 +448,7 @@ basic contents of the root file system of OS."
|
|||
(os-dir -> (derivation->output-path os-drv))
|
||||
(build-gid (operating-system-build-gid os))
|
||||
(profile (operating-system-profile-directory os)))
|
||||
(return `((directory "/nix/store" 0 ,(or build-gid 0))
|
||||
(return `((directory ,(%store-prefix) 0 ,(or build-gid 0))
|
||||
(directory "/etc")
|
||||
(directory "/var/log") ; for dmd
|
||||
(directory "/var/run/nscd")
|
||||
|
|
|
|||
|
|
@ -451,13 +451,13 @@ that form."
|
|||
;; This procedure is called frequently, so memoize it.
|
||||
(memoize
|
||||
(lambda* (path #:optional (output "out"))
|
||||
"Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
|
||||
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
|
||||
path of its output OUTPUT."
|
||||
(derivation->output-path (call-with-input-file path read-derivation)
|
||||
output))))
|
||||
|
||||
(define (derivation-path->output-paths path)
|
||||
"Read the derivation from PATH (`/nix/store/xxx.drv'), and return the
|
||||
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
|
||||
list of name/path pairs of its outputs."
|
||||
(derivation->output-paths (call-with-input-file path read-derivation)))
|
||||
|
||||
|
|
|
|||
|
|
@ -255,8 +255,9 @@ omitted. Write progress reports to LOG."
|
|||
(define uri
|
||||
(string->uri url))
|
||||
|
||||
(if (memq (uri-scheme uri) '(file #f))
|
||||
(add-to-store store name #f "sha256" (uri-path uri))
|
||||
(if (or (not uri) (memq (uri-scheme uri) '(file #f)))
|
||||
(add-to-store store name #f "sha256"
|
||||
(if uri (uri-path uri) url))
|
||||
(call-with-temporary-output-file
|
||||
(lambda (temp port)
|
||||
(let ((result
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
#:use-module (guix store)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix monads)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (guix pki)
|
||||
#:use-module (guix pk-crypto)
|
||||
|
|
@ -143,6 +144,24 @@ Export/import one or more packages from/to the store.\n"))
|
|||
|
||||
%standard-build-options))
|
||||
|
||||
(define (derivation-from-expression store str package-derivation
|
||||
system source?)
|
||||
"Read/eval STR and return the corresponding derivation path for SYSTEM.
|
||||
When SOURCE? is true and STR evaluates to a package, return the derivation of
|
||||
the package source; otherwise, use PACKAGE-DERIVATION to compute the
|
||||
derivation of a package."
|
||||
(match (read/eval str)
|
||||
((? package? p)
|
||||
(if source?
|
||||
(let ((source (package-source p)))
|
||||
(if source
|
||||
(package-source-derivation store source)
|
||||
(leave (_ "package `~a' has no source~%")
|
||||
(package-name p))))
|
||||
(package-derivation store p system)))
|
||||
((? procedure? proc)
|
||||
(run-with-store store (proc) #:system system))))
|
||||
|
||||
(define (options->derivations+files store opts)
|
||||
"Given OPTS, the result of 'args-fold', return a list of derivations to
|
||||
build and a list of store files to transfer."
|
||||
|
|
|
|||
|
|
@ -33,32 +33,13 @@
|
|||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-37)
|
||||
#:autoload (gnu packages) (find-best-packages-by-name)
|
||||
#:export (derivation-from-expression
|
||||
|
||||
%standard-build-options
|
||||
#:autoload (guix download) (download-to-store)
|
||||
#:export (%standard-build-options
|
||||
set-build-options-from-command-line
|
||||
show-build-options-help
|
||||
|
||||
guix-build))
|
||||
|
||||
(define (derivation-from-expression store str package-derivation
|
||||
system source?)
|
||||
"Read/eval STR and return the corresponding derivation path for SYSTEM.
|
||||
When SOURCE? is true and STR evaluates to a package, return the derivation of
|
||||
the package source; otherwise, use PACKAGE-DERIVATION to compute the
|
||||
derivation of a package."
|
||||
(match (read/eval str)
|
||||
((? package? p)
|
||||
(if source?
|
||||
(let ((source (package-source p)))
|
||||
(if source
|
||||
(package-source-derivation store source)
|
||||
(leave (_ "package `~a' has no source~%")
|
||||
(package-name p))))
|
||||
(package-derivation store p system)))
|
||||
((? procedure? proc)
|
||||
(run-with-store store (proc) #:system system))))
|
||||
|
||||
(define (specification->package spec)
|
||||
"Return a package matching SPEC. SPEC may be a package name, or a package
|
||||
name followed by a hyphen and a version number. If the version number is not
|
||||
|
|
@ -104,6 +85,31 @@ present, return the preferred newest version."
|
|||
(leave (_ "failed to create GC root `~a': ~a~%")
|
||||
root (strerror (system-error-errno args)))))))
|
||||
|
||||
(define (package-with-source store p uri)
|
||||
"Return a package based on P but with its source taken from URI. Extract
|
||||
the new package's version number from URI."
|
||||
(define (numeric-extension? file-name)
|
||||
;; Return true if FILE-NAME ends with digits.
|
||||
(string-every char-set:hex-digit (file-extension file-name)))
|
||||
|
||||
(define (tarball-base-name file-name)
|
||||
;; Return the "base" of FILE-NAME, removing '.tar.gz' or similar
|
||||
;; extensions.
|
||||
;; TODO: Factorize.
|
||||
(cond ((numeric-extension? file-name)
|
||||
file-name)
|
||||
((string=? (file-extension file-name) "tar")
|
||||
(file-sans-extension file-name))
|
||||
(else
|
||||
(tarball-base-name (file-sans-extension file-name)))))
|
||||
|
||||
(let ((base (tarball-base-name (basename uri))))
|
||||
(let-values (((name version)
|
||||
(package-name->name+version base)))
|
||||
(package (inherit p)
|
||||
(version (or version (package-version p)))
|
||||
(source (download-to-store store uri))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Standard command-line build options.
|
||||
|
|
@ -221,6 +227,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
|
|||
-s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
|
||||
(display (_ "
|
||||
--target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
|
||||
(display (_ "
|
||||
--with-source=SOURCE
|
||||
use SOURCE when building the corresponding package"))
|
||||
(display (_ "
|
||||
-d, --derivations return the derivation paths of the given packages"))
|
||||
(display (_ "
|
||||
|
|
@ -274,6 +283,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
|
|||
(option '("log-file") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'log-file? #t result)))
|
||||
(option '("with-source") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'with-source arg result)))
|
||||
|
||||
%standard-build-options))
|
||||
|
||||
|
|
@ -289,24 +301,81 @@ build."
|
|||
(define src? (assoc-ref opts 'source?))
|
||||
(define sys (assoc-ref opts 'system))
|
||||
|
||||
(let ((opts (options/with-source store
|
||||
(options/resolve-packages store opts))))
|
||||
(filter-map (match-lambda
|
||||
(('expression . str)
|
||||
(derivation-from-expression store str package->derivation
|
||||
sys src?))
|
||||
(('argument . (? package? p))
|
||||
(if src?
|
||||
(let ((s (package-source p)))
|
||||
(package-source-derivation store s))
|
||||
(package->derivation store p sys)))
|
||||
(('argument . (? derivation? drv))
|
||||
drv)
|
||||
(('argument . (? derivation-path? drv))
|
||||
(call-with-input-file drv read-derivation))
|
||||
(('argument . (? store-path?))
|
||||
;; Nothing to do; maybe for --log-file.
|
||||
#f)
|
||||
(('argument . (? string? x))
|
||||
(let ((p (specification->package x)))
|
||||
(if src?
|
||||
(let ((s (package-source p)))
|
||||
(package-source-derivation store s))
|
||||
(package->derivation store p sys))))
|
||||
(_ #f))
|
||||
opts)))
|
||||
|
||||
(define (options/resolve-packages store opts)
|
||||
"Return OPTS with package specification strings replaced by actual
|
||||
packages."
|
||||
(define system
|
||||
(or (assoc-ref opts 'system) (%current-system)))
|
||||
|
||||
(map (match-lambda
|
||||
(('argument . (? string? spec))
|
||||
(if (store-path? spec)
|
||||
`(argument . ,spec)
|
||||
`(argument . ,(specification->package spec))))
|
||||
(('expression . str)
|
||||
(match (read/eval str)
|
||||
((? package? p)
|
||||
`(argument . ,p))
|
||||
((? procedure? proc)
|
||||
(let ((drv (run-with-store store (proc) #:system system)))
|
||||
`(argument . ,drv)))))
|
||||
(opt opt))
|
||||
opts))
|
||||
|
||||
(define (options/with-source store opts)
|
||||
"Process with 'with-source' options in OPTS, replacing the relevant package
|
||||
arguments with packages that use the specified source."
|
||||
(define new-sources
|
||||
(filter-map (match-lambda
|
||||
(('with-source . uri)
|
||||
(cons (package-name->name+version (basename uri))
|
||||
uri))
|
||||
(_ #f))
|
||||
opts))
|
||||
|
||||
(let loop ((opts opts)
|
||||
(sources new-sources)
|
||||
(result '()))
|
||||
(match opts
|
||||
(()
|
||||
(unless (null? sources)
|
||||
(warning (_ "sources do not match any package:~{ ~a~}~%")
|
||||
(match sources
|
||||
(((name . uri) ...)
|
||||
uri))))
|
||||
(reverse result))
|
||||
((('argument . (? package? p)) tail ...)
|
||||
(let ((source (assoc-ref sources (package-name p))))
|
||||
(loop tail
|
||||
(alist-delete (package-name p) sources)
|
||||
(alist-cons 'argument
|
||||
(if source
|
||||
(package-with-source store p source)
|
||||
p)
|
||||
result))))
|
||||
((('with-source . _) tail ...)
|
||||
(loop tail sources result))
|
||||
((head tail ...)
|
||||
(loop tail sources (cons head result))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Entry point.
|
||||
|
|
|
|||
|
|
@ -56,6 +56,8 @@
|
|||
build-machine make-build-machine
|
||||
build-machine?
|
||||
(name build-machine-name) ; string
|
||||
(port build-machine-port ; number
|
||||
(default 22))
|
||||
(system build-machine-system) ; string
|
||||
(user build-machine-user) ; string
|
||||
(private-key build-machine-private-key ; file name
|
||||
|
|
@ -161,8 +163,9 @@ determined."
|
|||
"Run COMMAND on MACHINE, assuming an lsh gateway has been set up."
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(apply open-pipe* mode %lshg-command
|
||||
"-l" (build-machine-user machine) "-z"
|
||||
(apply open-pipe* mode %lshg-command "-z"
|
||||
"-l" (build-machine-user machine)
|
||||
"-p" (number->string (build-machine-port machine))
|
||||
|
||||
;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
|
||||
"-i" (build-machine-private-key machine)
|
||||
|
|
@ -328,6 +331,7 @@ success, #f otherwise."
|
|||
(missing (filtered-port
|
||||
(list (which %lshg-command)
|
||||
"-l" (build-machine-user machine)
|
||||
"-p" (number->string (build-machine-port machine))
|
||||
"-i" (build-machine-private-key machine)
|
||||
(build-machine-name machine)
|
||||
"guix" "archive" "--missing")
|
||||
|
|
@ -462,10 +466,14 @@ allowed on MACHINE."
|
|||
machines))
|
||||
|
||||
(define (undecorate pred)
|
||||
(match-lambda
|
||||
((machine slot)
|
||||
(and (pred machine)
|
||||
(list machine slot)))))
|
||||
(lambda (a b)
|
||||
(match a
|
||||
((machine1 slot1)
|
||||
(match b
|
||||
((machine2 slot2)
|
||||
(if (pred machine1 machine2)
|
||||
(list machine1 slot1)
|
||||
(list machine2 slot2))))))))
|
||||
|
||||
(let ((machines+slots (sort machines+slots
|
||||
(undecorate machine-less-loaded-or-faster?))))
|
||||
|
|
|
|||
|
|
@ -57,6 +57,7 @@
|
|||
set-build-options
|
||||
valid-path?
|
||||
query-path-hash
|
||||
hash-part->path
|
||||
add-text-to-store
|
||||
add-to-store
|
||||
build-derivations
|
||||
|
|
@ -501,6 +502,18 @@ encoding conversion errors."
|
|||
"Return the SHA256 hash of PATH as a bytevector."
|
||||
base16)
|
||||
|
||||
(define hash-part->path
|
||||
(let ((query-path-from-hash-part
|
||||
(operation (query-path-from-hash-part (string hash))
|
||||
#f
|
||||
store-path)))
|
||||
(lambda (server hash-part)
|
||||
"Return the store path whose hash part is HASH-PART (a nix-base32
|
||||
string). Raise an error if no such path exists."
|
||||
;; This RPC is primarily used by Hydra to reply to HTTP GETs of
|
||||
;; /HASH.narinfo.
|
||||
(query-path-from-hash-part server hash-part))))
|
||||
|
||||
(define add-text-to-store
|
||||
;; A memoizing version of `add-to-store', to avoid repeated RPCs with
|
||||
;; the very same arguments during a given session.
|
||||
|
|
|
|||
|
|
@ -87,7 +87,12 @@
|
|||
(%store-prefix)
|
||||
"/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))))
|
||||
|
||||
(test-skip (if %store 0 10))
|
||||
(test-skip (if %store 0 11))
|
||||
|
||||
(test-assert "hash-part->path"
|
||||
(let ((p (add-text-to-store %store "hello" "hello, world")))
|
||||
(equal? (hash-part->path %store (store-path-hash-part p))
|
||||
p)))
|
||||
|
||||
(test-assert "dead-paths"
|
||||
(let ((p (add-text-to-store %store "random-text" (random-text))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue