summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/guix.texi31
-rw-r--r--gnu-system.am2
-rw-r--r--gnu/packages/gcc.scm4
-rw-r--r--gnu/packages/guile-wm.scm26
-rw-r--r--gnu/packages/linux.scm35
-rw-r--r--gnu/packages/patches/pulseaudio-test-timeouts.patch19
-rw-r--r--gnu/packages/patches/pulseaudio-volume-test.patch29
-rw-r--r--gnu/packages/pulseaudio.scm7
-rw-r--r--gnu/packages/python.scm4
-rw-r--r--gnu/system/vm.scm4
-rw-r--r--guix/derivations.scm4
-rw-r--r--guix/download.scm5
-rw-r--r--guix/scripts/archive.scm19
-rw-r--r--guix/scripts/build.scm139
-rw-r--r--guix/scripts/offload.scm20
-rw-r--r--guix/store.scm13
-rw-r--r--tests/store.scm7
17 files changed, 241 insertions, 127 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 701b5400f8..f97051e88c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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
diff --git a/gnu-system.am b/gnu-system.am
index 9f4f959d46..52c58d8c90 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -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 \
diff --git a/gnu/packages/gcc.scm b/gnu/packages/gcc.scm
index 279cc8d950..cb7817c084 100644
--- a/gnu/packages/gcc.scm
+++ b/gnu/packages/gcc.scm
@@ -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")))
diff --git a/gnu/packages/guile-wm.scm b/gnu/packages/guile-wm.scm
index b05974c8ae..38c5959340 100644
--- a/gnu/packages/guile-wm.scm
+++ b/gnu/packages/guile-wm.scm
@@ -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)))
diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm
index e1668b1d6b..b5e15400e1 100644
--- a/gnu/packages/linux.scm
+++ b/gnu/packages/linux.scm
@@ -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")))))
diff --git a/gnu/packages/patches/pulseaudio-test-timeouts.patch b/gnu/packages/patches/pulseaudio-test-timeouts.patch
deleted file mode 100644
index ab818ad0aa..0000000000
--- a/gnu/packages/patches/pulseaudio-test-timeouts.patch
+++ /dev/null
@@ -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);
diff --git a/gnu/packages/patches/pulseaudio-volume-test.patch b/gnu/packages/patches/pulseaudio-volume-test.patch
deleted file mode 100644
index 2cfa0cd6ca..0000000000
--- a/gnu/packages/patches/pulseaudio-volume-test.patch
+++ /dev/null
@@ -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
diff --git a/gnu/packages/pulseaudio.scm b/gnu/packages/pulseaudio.scm
index 8bf48c2a89..db7e752ee6 100644
--- a/gnu/packages/pulseaudio.scm
+++ b/gnu/packages/pulseaudio.scm
@@ -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"
diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm
index ad1ac5c8f7..7997618fcf 100644
--- a/gnu/packages/python.scm
+++ b/gnu/packages/python.scm
@@ -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
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index b6a777353f..a23289a30b 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -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")
diff --git a/guix/derivations.scm b/guix/derivations.scm
index b47ab93759..4d11434e3a 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -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)))
diff --git a/guix/download.scm b/guix/download.scm
index 0889928d3a..2cb0740897 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -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
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 8280a821c5..0ab7686585 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -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."
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 618015e9ba..35b10a0ec2 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -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.
@@ -222,6 +228,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
(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 (_ "
-r, --root=FILE make FILE a symlink to the result, and register it
@@ -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,23 +301,80 @@ build."
(define src? (assoc-ref opts 'source?))
(define sys (assoc-ref opts 'system))
- (filter-map (match-lambda
- (('expression . str)
- (derivation-from-expression store str package->derivation
- sys src?))
- (('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)))
+ (let ((opts (options/with-source store
+ (options/resolve-packages store opts))))
+ (filter-map (match-lambda
+ (('argument . (? package? p))
(if src?
(let ((s (package-source p)))
(package-source-derivation store s))
- (package->derivation store p sys))))
- (_ #f))
- opts))
+ (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)
+ (_ #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))))))
;;;
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 4d2f78f711..95e35088a1 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -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?))))
diff --git a/guix/store.scm b/guix/store.scm
index 909ef195de..58f7e36762 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -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.
diff --git a/tests/store.scm b/tests/store.scm
index 8a25c7353b..78023a423d 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -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))))
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-07 11:29:39 +0000