diff options
| -rw-r--r-- | doc/guix.texi | 31 | ||||
| -rw-r--r-- | gnu-system.am | 2 | ||||
| -rw-r--r-- | gnu/packages/gcc.scm | 4 | ||||
| -rw-r--r-- | gnu/packages/guile-wm.scm | 26 | ||||
| -rw-r--r-- | gnu/packages/linux.scm | 35 | ||||
| -rw-r--r-- | gnu/packages/patches/pulseaudio-test-timeouts.patch | 19 | ||||
| -rw-r--r-- | gnu/packages/patches/pulseaudio-volume-test.patch | 29 | ||||
| -rw-r--r-- | gnu/packages/pulseaudio.scm | 7 | ||||
| -rw-r--r-- | gnu/packages/python.scm | 4 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 4 | ||||
| -rw-r--r-- | guix/derivations.scm | 4 | ||||
| -rw-r--r-- | guix/download.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/archive.scm | 19 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 139 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 20 | ||||
| -rw-r--r-- | guix/store.scm | 13 | ||||
| -rw-r--r-- | tests/store.scm | 7 |
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)))) |