8 files changed, 136 insertions(+), 7 deletions(-)

M doc/guix.texi
M gnu-system.am
M gnu/packages/base.scm
M gnu/packages/gettext.scm
A gnu/packages/patches/glibc-locales.patch
M guix/derivations.scm
M guix/gexp.scm
M tests/gexp.scm

@@ 2583,8 2583,8 @@ information about monads.)
        [#:hash #f] [#:hash-algo #f] @
        [#:recursive? #f] [#:env-vars '()] [#:modules '()] @
        [#:module-path @var{%load-path}] @
-       [#:references-graphs #f] [#:local-build? #f] @
-       [#:guile-for-build #f]
+       [#:references-graphs #f] [#:allowed-references #f] @
+       [#:local-build? #f] [#:guile-for-build #f]
 Return a derivation @var{name} that runs @var{exp} (a gexp) with
 @var{guile-for-build} (a derivation) on @var{system}.  When @var{target}
 is true, it is used as the cross-compilation target triplet for packages


@@ 2612,6 2612,10 @@ an input of the build process of @var{exp}.  In the build environment, each
 @var{file-name} contains the reference graph of the corresponding item, in a simple
 text format.
 
+@var{allowed-references} must be either @code{#f} or a list of output names and packages.
+In the latter case, the list denotes store items that the result is allowed to
+refer to.  Any reference to another store item will lead to a build error.
+
 The other arguments are as for @code{derivation} (@pxref{Derivations}).
 @end deffn
 


@@ 3490,7 3494,7 @@ to report issues (and success stories!), and join us in improving it.
 @subsection USB Stick Installation
 
 An installation image for USB sticks can be downloaded from
-@url{ftp://alpha.gnu.org/gnu/guix/gsd-usb-install-@value{VERSION}.@var{system}.xz},
+@code{ftp://alpha.gnu.org/gnu/guix/gsd-usb-install-@value{VERSION}.@var{system}.xz},
 where @var{system} is one of:
 
 @table @code

@@ 391,6 391,7 @@ dist_patch_DATA =						\
   gnu/packages/patches/glib-tests-gapplication.patch		\
   gnu/packages/patches/glibc-bootstrap-system.patch		\
   gnu/packages/patches/glibc-ldd-x86_64.patch			\
+  gnu/packages/patches/glibc-locales.patch			\
   gnu/packages/patches/gmp-arm-asm-nothumb.patch		\
   gnu/packages/patches/gnunet-fix-scheduler.patch		\
   gnu/packages/patches/gnunet-fix-tests.patch    		\

@@ 33,6 33,7 @@
   #:use-module (gnu packages linux)
   #:use-module (gnu packages texinfo)
   #:use-module (gnu packages pkg-config)
+  #:use-module (guix utils)
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix build-system gnu))


@@ 503,6 504,41 @@ with the Linux kernel.")
    (license lgpl2.0+)
    (home-page "http://www.gnu.org/software/libc/")))
 
+(define-public glibc-locales
+  (package
+    (inherit glibc)
+    (name "glibc-locales")
+    (source (origin (inherit (package-source glibc))
+                    (patches (cons (search-patch "glibc-locales.patch")
+                                   (origin-patches (package-source glibc))))))
+    (synopsis "All the locales supported by the GNU C Library")
+    (description
+     "This package provides all the locales supported by the GNU C Library,
+more than 400 in total.  To use them set the 'LOCPATH' environment variable to
+the 'share/locale' sub-directory of this package.")
+    (outputs '("out"))                            ;110+ MiB
+    (native-search-paths '())
+    (arguments
+     (let ((args `(#:tests? #f #:strip-binaries? #f
+                   ,@(package-arguments glibc))))
+       (substitute-keyword-arguments args
+         ((#:phases phases)
+          `(alist-replace
+            'build
+            (lambda* (#:key outputs #:allow-other-keys)
+              (let ((out (assoc-ref outputs "out")))
+                ;; Delete $out/bin, which contains 'bash'.
+                (delete-file-recursively (string-append out "/bin")))
+
+              (zero? (system* "make" "localedata/install-locales"
+                              "-j" (number->string (parallel-job-count)))))
+            (alist-delete 'install ,phases)))
+         ((#:configure-flags flags)
+          `(append ,flags
+                   (list (string-append "libc_cv_localedir="
+                                        (assoc-ref %outputs "out")
+                                        "/share/locale")))))))))
+
 (define-public tzdata
   (package
     (name "tzdata")

@@ 18,7 18,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu packages gettext)
-  #:use-module ((guix licenses) #:select (gpl3))
+  #:use-module ((guix licenses) #:select (gpl3+))
   #:use-module (gnu packages)
   #:use-module (guix packages)
   #:use-module (guix download)


@@ 78,4 78,4 @@ textual output of programs into multiple languages.  It provides translators
 with the means to create message catalogs, as well as an Emacs mode to work
 with them, and a runtime library to load translated messages from the
 catalogs.  Nearly all GNU packages use Gettext.")
-    (license gpl3))) ; some files are under GPLv2+
+    (license gpl3+)))                             ;some files are under GPLv2+

@@ 0,0 1,31 @@
+This patch allows us to use glibc's build system to build locales
+in a package separate from glibc.
+
+  1. Use 'localedef' from $PATH since we are not rebuilding it.
+  2. Use '--no-archive' to avoid building the big locale archive, and
+     because the already-built 'localedef' would want to write it
+     to '/run/current-system/locale', which is not possible.
+  3. Pass $(localedir)/$$locale to install files in the right place, and
+     because otherwise, 'localedef' fails with:
+     "cannot write output files to `(null)'".
+
+--- glibc-2.20/localedata/Makefile	2014-09-07 10:09:09.000000000 +0200
++++ glibc-2.20/localedata/Makefile	2015-02-11 10:23:55.560545568 +0100
+@@ -217,7 +217,7 @@ INSTALL-SUPPORTED-LOCALES=$(addprefix in
+ 
+ # Sometimes the whole collection of locale files should be installed.
+ LOCALEDEF=I18NPATH=. GCONV_PATH=$(common-objpfx)iconvdata LC_ALL=C \
+-$(rtld-prefix) $(common-objpfx)locale/localedef
++  localedef --no-archive
+ install-locales: $(INSTALL-SUPPORTED-LOCALES)
+ 
+ install-locales-dir:
+@@ -234,7 +234,7 @@ $(INSTALL-SUPPORTED-LOCALES): install-lo
+ 	input=`echo $$locale | sed 's/\([^.]*\)[^@]*\(.*\)/\1\2/'`; \
+ 	$(LOCALEDEF) --alias-file=../intl/locale.alias \
+ 		     -i locales/$$input -c -f charmaps/$$charset \
+-		     $(addprefix --prefix=,$(install_root)) $$locale; \
++		     $(addprefix --prefix=,$(install_root)) $(localedir)/$$locale; \
+ 	echo ' done'; \
+ 
+ tst-setlocale-ENV = LC_ALL=ja_JP.EUC-JP

@@ 1095,6 1095,7 @@ applied."
        (let ((mapping ',mapping))
          (for-each (lambda (input output)
                      (format #t "grafting '~a' -> '~a'...~%" input output)
+                     (force-output)
                      (rewrite-directory input output
                                         `((,input . ,output)
                                           ,@mapping)))

@@ 118,6 118,29 @@ corresponding derivation."
                                                #:target target)))
        (return (map cons file-names inputs))))))
 
+(define* (lower-references lst #:key system target)
+  "Based on LST, a list of output names and packages, return a list of output
+names and file names suitable for the #:allowed-references argument to
+'derivation'."
+  ;; XXX: Currently outputs other than "out" are not supported, and things
+  ;; other than packages aren't either.
+  (with-monad %store-monad
+    (define lower
+      (match-lambda
+       ((? string? output)
+        (return output))
+       ((? package? package)
+        (mlet %store-monad ((drv
+                             (if target
+                                 (package->cross-derivation package target
+                                                            #:system system
+                                                            #:graft? #f)
+                                 (package->derivation package system
+                                                      #:graft? #f))))
+          (return (derivation->output-path drv))))))
+
+    (sequence %store-monad (map lower lst))))
+
 (define* (gexp->derivation name exp
                            #:key
                            system (target 'current)


@@ 127,6 150,7 @@ corresponding derivation."
                            (module-path %load-path)
                            (guile-for-build (%guile-for-build))
                            references-graphs
+                           allowed-references
                            local-build?)
   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
 derivation) on SYSTEM.  When TARGET is true, it is used as the


@@ 151,8 175,9 @@ an input of the build process of EXP.  In the build environment, each
 FILE-NAME contains the reference graph of the corresponding item, in a simple
 text format.
 
-In that case, the reference graph of each store path is exported in
-the build environment in the corresponding file, in a simple text format.
+ALLOWED-REFERENCES must be either #f or a list of output names and packages.
+In the latter case, the list denotes store items that the result is allowed to
+refer to.  Any reference to another store item will lead to a build error.
 
 The other arguments are as for 'derivation'."
   (define %modules modules)


@@ 207,6 232,11 @@ The other arguments are as for 'derivation'."
                                                              #:system system
                                                              #:target target)
                                      (return #f)))
+                       (allowed  (if allowed-references
+                                     (lower-references allowed-references
+                                                       #:system system
+                                                       #:target target)
+                                     (return #f)))
                        (guile    (if guile-for-build
                                      (return guile-for-build)
                                      (package->derivation (default-guile)


@@ 233,6 263,7 @@ The other arguments are as for 'derivation'."
                                    (_ '())))
                     #:hash hash #:hash-algo hash-algo #:recursive? recursive?
                     #:references-graphs (and=> graphs graphs-file-names)
+                    #:allowed-references allowed
                     #:local-build? local-build?)))
 
 (define* (gexp-inputs exp #:optional (references gexp-references))

@@ 27,6 27,7 @@
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 match)


@@ 396,6 397,30 @@
                  (equal? (call-with-input-file g-guile read)
                          (list (derivation->output-path guile-drv)))))))
 
+(test-assertm "gexp->derivation #:allowed-references"
+  (mlet %store-monad ((drv (gexp->derivation "allowed-refs"
+                                             #~(begin
+                                                 (mkdir #$output)
+                                                 (chdir #$output)
+                                                 (symlink #$output "self")
+                                                 (symlink #$%bootstrap-guile
+                                                          "guile"))
+                                             #:allowed-references
+                                             (list "out" %bootstrap-guile))))
+    (built-derivations (list drv))))
+
+(test-assert "gexp->derivation #:allowed-references, disallowed"
+  (let ((drv (run-with-store %store
+               (gexp->derivation "allowed-refs"
+                                 #~(begin
+                                     (mkdir #$output)
+                                     (chdir #$output)
+                                     (symlink #$%bootstrap-guile "guile"))
+                                 #:allowed-references '()))))
+    (guard (c ((nix-protocol-error? c) #t))
+      (build-derivations %store (list drv))
+      #f)))
+
 (define shebang
   (string-append "#!" (derivation->output-path (%guile-for-build))
                  "/bin/guile --no-auto-compile"))