Merge branch 'master' into core-updates

2014-03-17 18:26:46 +01:00 · 2014-03-17 18:26:46 +01:00 · 0562dbe5d3
parent bfb6b1c7b7 9b43a0ffa3
commit 0562dbe5d3
17 changed files with 241 additions and 127 deletions
--- 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
--- 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		\
--- 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")))
--- 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)))
--- 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")))))
--- a/gnu/packages/patches/pulseaudio-test-timeouts.patch
+++ b/gnu/packages/patches/pulseaudio-test-timeouts.patch
@ -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);
--- a/gnu/packages/patches/pulseaudio-volume-test.patch
+++ b/gnu/packages/patches/pulseaudio-volume-test.patch
@ -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
--- 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"
--- 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
--- 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")
--- 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)))

--- 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
--- 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."
--- 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.
@ -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,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))))))


 ;;;
--- 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?))))
--- 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.
--- 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))))