Merge branch 'master' into core-updates

doc/guix.texi

@@ -11920,6 +11920,17 @@ The Linux kernel image to boot, for example:
 (file-append linux-libre "/bzImage")
 @end example
 
+It is also possible to specify a device explicitly in the file path
+using GRUB's device naming convention (@pxref{Naming convention,,, grub,
+GNU GRUB manual}), for example:
+
+@example
+"(hd0,msdos1)/boot/vmlinuz"
+@end example
+
+If the device is specified explicitly as above, then the @code{device}
+field is ignored entirely.
+
 @item @code{linux-arguments} (default: @code{()})
 The list of extra Linux kernel command-line arguments---e.g.,
 @code{("console=ttyS0")}.
@@ -11928,6 +11939,22 @@ The list of extra Linux kernel command-line arguments---e.g.,
 A G-Expression or string denoting the file name of the initial RAM disk
 to use (@pxref{G-Expressions}).
 
+@item @code{device} (default: @code{#f})
+The device where the kernel and initrd are to be found---i.e., the GRUB
+@dfn{root} for this menu entry (@pxref{root,,, grub, GNU GRUB manual}).
+
+This may be a file system label (a string), a file system UUID (a
+bytevector, @pxref{File Systems}), or @code{#f}, in which case GRUB will
+search the device containing the file specified by the @code{linux}
+field (@pxref{search,,, grub, GNU GRUB manual}).  It must @emph{not} be
+an OS device name such as @file{/dev/sda1}.
+
+@item @code{device-mount-point} (default: @code{"/"})
+The mount point of the above device on the system.  You probably do not
+need to change the default value.  GuixSD uses it to strip the prefix of
+store file names for systems where @file{/gnu} or @file{/gnu/store} is
+on a separate partition.
+
 @end table
 @end deftp
 

gnu/local.mk

@@ -657,6 +657,7 @@ dist_patch_DATA =						\
   %D%/packages/patches/libtiff-CVE-2016-5314.patch		\
   %D%/packages/patches/libtiff-CVE-2016-5321.patch		\
   %D%/packages/patches/libtiff-CVE-2016-5323.patch		\
+  %D%/packages/patches/libtiff-CVE-2016-5652.patch		\
   %D%/packages/patches/libtiff-oob-accesses-in-decode.patch	\
   %D%/packages/patches/libtiff-oob-write-in-nextdecode.patch	\
   %D%/packages/patches/libtool-skip-tests2.patch		\

gnu/packages/emacs.scm

@@ -1652,14 +1652,14 @@ (define-public emacs-ob-ipython
 (define-public emacs-debbugs
   (package
     (name "emacs-debbugs")
-    (version "0.9")
+    (version "0.11")
     (source (origin
               (method url-fetch)
               (uri (string-append "https://elpa.gnu.org/packages/debbugs-"
                                   version ".tar"))
               (sha256
                (base32
-                "1wc6kw7hihqqdx8qyl01akygycnan44x400hwrcf54m3hb4isa0k"))))
+                "10v9s7ayvfzd6j6hqfc9zihxgmsc2j0xhxrgy3ah30qkqn6z8w6n"))))
     (build-system emacs-build-system)
     (propagated-inputs
      `(("emacs-async" ,emacs-async)))

gnu/packages/image.scm

@@ -186,6 +186,7 @@ (define-public libicns
 (define-public libtiff
   (package
    (name "libtiff")
+   (replacement libtiff/fixed)
    (version "4.0.6")
    (source (origin
             (method url-fetch)
@@ -225,6 +226,24 @@ (define-public libtiff
                                   "See COPYRIGHT in the distribution."))
    (home-page "http://www.remotesensing.org/libtiff/")))
 
+(define libtiff/fixed
+  (package
+    (inherit libtiff)
+    (source (origin
+              (inherit (package-source libtiff))
+              (patches (search-patches
+                         "libtiff-oob-accesses-in-decode.patch"
+                         "libtiff-oob-write-in-nextdecode.patch"
+                         "libtiff-CVE-2015-8665+CVE-2015-8683.patch"
+                         "libtiff-CVE-2016-3623.patch"
+                         "libtiff-CVE-2016-3945.patch"
+                         "libtiff-CVE-2016-3990.patch"
+                         "libtiff-CVE-2016-3991.patch"
+                         "libtiff-CVE-2016-5314.patch"
+                         "libtiff-CVE-2016-5321.patch"
+                         "libtiff-CVE-2016-5323.patch"
+                         "libtiff-CVE-2016-5652.patch"))))))
+
 (define-public libwmf
   (package
     (name "libwmf")

gnu/packages/libusb.scm

@@ -105,7 +105,8 @@ (define-public python-pyusb
     (build-system python-build-system)
     (arguments
      `(#:tests? #f  ;no tests
-       #:modules ((srfi srfi-26)
+       #:modules ((srfi srfi-1)
+                  (srfi srfi-26)
                   (guix build utils)
                   (guix build python-build-system))
        #:phases
@@ -116,11 +117,9 @@ (define-public python-pyusb
                (("lib = locate_library\\(candidates, find_library\\)")
                 (string-append
                  "lib = \""
-                 (car (find-files (assoc-ref inputs "libusb")
+                 (find (negate symbolic-link?)
-                                  (lambda (file stat)
+                       (find-files (assoc-ref inputs "libusb")
-                                    (and ((file-name-predicate
+                                   "^libusb-.*\\.so\\..*"))
-                                           "^libusb-.*\\.so\\..*") file stat)
-                                         (not (symbolic-link? file))))))
                  "\"")))
              #t)))))
     (inputs

gnu/packages/networking.scm

@@ -991,3 +991,37 @@ (define-public iperf
                    license:ncsa              ; src/{units,iperf_locale,tcp_window_size}.c
                    license:expat             ; src/{cjson,net}.[ch]
                    license:public-domain)))) ; src/portable_endian.h
+
+(define-public nethogs
+  (package
+    (name "nethogs")
+    (version "0.8.5")
+    (source (origin
+              (method url-fetch)
+              (uri (string-append "https://github.com/raboof/nethogs/archive/v"
+                                  version ".tar.gz"))
+              (sha256
+               (base32
+                "1k4x8r7s4dgcb6n2rjn28h2yyij92mwm69phncl3597cdxr954va"))
+              (file-name (string-append name "-" version ".tar.gz"))))
+    (build-system gnu-build-system)
+    (inputs
+     `(("libpcap" ,libpcap)
+       ("ncurses" ,ncurses)))
+    (arguments
+     `(#:make-flags `("CC=gcc"
+                      ,(string-append "PREFIX=" %output))
+       #:phases
+       (modify-phases %standard-phases
+         (delete 'configure)))) ; No ./configure script.
+    (home-page "https://github.com/raboof/nethogs")
+    (synopsis "Per-process bandwidth monitor")
+    (description "NetHogs is a small 'net top' tool for Linux.  Instead of
+breaking the traffic down per protocol or per subnet, like most tools do, it
+groups bandwidth by process.
+
+NetHogs does not rely on a special kernel module to be loaded.  If there's
+suddenly a lot of network traffic, you can fire up NetHogs and immediately see
+which PID is causing this.  This makes it easy to identify programs that have
+gone wild and are suddenly taking up your bandwidth.")
+    (license license:gpl2+)))

gnu/packages/package-management.scm

@@ -159,7 +159,17 @@ (define (copy arch)
 
                        #t))))))
     (native-inputs `(("pkg-config" ,pkg-config)
-                     ("emacs" ,emacs-minimal)))   ;for guix.el
+                     ("emacs" ,emacs-minimal)     ;for guix.el
+
+                     ;; XXX: Keep the development inputs here even though
+                     ;; they're unnecessary, just so that 'guix environment
+                     ;; guix' always contains them.
+                     ("autoconf" ,(autoconf-wrapper))
+                     ("automake" ,automake)
+                     ("gettext" ,gnu-gettext)
+                     ("texinfo" ,texinfo)
+                     ("graphviz" ,graphviz)
+                     ("help2man" ,help2man)))
     (inputs
      (let ((boot-guile (lambda (arch hash)
                          (origin
@@ -243,15 +253,7 @@ (define guix-devel
                             (chmod po #o666))
                           (find-files "." "\\.po$"))
 
-                (zero? (system* "sh" "bootstrap"))))))))
+                (zero? (system* "sh" "bootstrap")))))))))))
-      (native-inputs
-       `(("autoconf" ,(autoconf-wrapper))
-         ("automake" ,automake)
-         ("gettext" ,gettext-minimal)
-         ("texinfo" ,texinfo)
-         ("graphviz" ,graphviz)
-         ("help2man" ,help2man)
-         ,@(package-native-inputs guix-0.11.0))))))
 
 (define-public guix guix-devel)
 

gnu/packages/patches/libtiff-CVE-2016-5652.patch

@@ -0,0 +1,47 @@
+Fix CVE-2016-5652 (buffer overflow in t2p_readwrite_pdf_image_tile()).
+
+https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2016-5652
+
+Patches exfiltrated from upstream CVS repo with:
+cvs diff -u -r 1.92 -r 1.94 tools/tiff2pdf.c
+
+Index: tools/tiff2pdf.c
+===================================================================
+RCS file: /cvs/maptools/cvsroot/libtiff/tools/tiff2pdf.c,v
+retrieving revision 1.92
+retrieving revision 1.94
+diff -u -r1.92 -r1.94
+--- a/tools/tiff2pdf.c	23 Sep 2016 22:12:18 -0000	1.92
++++ b/tools/tiff2pdf.c	9 Oct 2016 11:03:36 -0000	1.94
+@@ -2887,21 +2887,24 @@
+ 				return(0);
+ 			}
+ 			if(TIFFGetField(input, TIFFTAG_JPEGTABLES, &count, &jpt) != 0) {
+-				if (count > 0) {
+-					_TIFFmemcpy(buffer, jpt, count);
++				if (count >= 4) {
++                    /* Ignore EOI marker of JpegTables */
++					_TIFFmemcpy(buffer, jpt, count - 2);
+ 					bufferoffset += count - 2;
++                    /* Store last 2 bytes of the JpegTables */
+ 					table_end[0] = buffer[bufferoffset-2];
+ 					table_end[1] = buffer[bufferoffset-1];
+-				}
+-				if (count > 0) {
+ 					xuint32 = bufferoffset;
++                    bufferoffset -= 2;
+ 					bufferoffset += TIFFReadRawTile(
+ 						input, 
+ 						tile, 
+-						(tdata_t) &(((unsigned char*)buffer)[bufferoffset-2]), 
++						(tdata_t) &(((unsigned char*)buffer)[bufferoffset]), 
+ 						-1);
+-						buffer[xuint32-2]=table_end[0];
+-						buffer[xuint32-1]=table_end[1];
++                    /* Overwrite SOI marker of image scan with previously */
++                    /* saved end of JpegTables */
++					buffer[xuint32-2]=table_end[0];
++					buffer[xuint32-1]=table_end[1];
+ 				} else {
+ 					bufferoffset += TIFFReadRawTile(
+ 						input, 

gnu/packages/python.scm

@@ -5307,7 +5307,7 @@ (define-public python-waf
     (version "1.9.5")
     (source (origin
               (method url-fetch)
-              (uri (string-append "http://waf.io/"
+              (uri (string-append "https://waf.io/"
                                   "waf-" version ".tar.bz2"))
               (sha256
                (base32
@@ -11569,3 +11569,30 @@ (define-public python-pyev
 
 (define-public python2-pyev
   (package-with-python2 python-pyev))
+
+(define-public python-imagesize
+  (package
+    (name "python-imagesize")
+    (version "0.7.1")
+    (source
+      (origin
+      (method url-fetch)
+      (uri (pypi-uri "imagesize" version))
+      (sha256
+        (base32
+          "0qk07k0z4241lkzzjji7z4da04pcvg7bfc4xz1934zlqhwmwdcha"))))
+    (build-system python-build-system)
+    (home-page "https://github.com/shibukawa/imagesize_py")
+    (synopsis "Gets image size of files in variaous formats in Python")
+    (description
+      "This package allows determination of image size from
+PNG, JPEG, JPEG2000 and GIF files in pure Python.")
+    (license license:expat)
+    (properties `((python2-variant . ,(delay python2-imagesize))))))
+
+(define-public python2-imagesize
+  (let ((base (package-with-python2 (strip-python2-variant python-imagesize))))
+    (package
+      (inherit base)
+      (native-inputs `(("python2-setuptools" ,python2-setuptools)
+                       ,@(package-native-inputs base))))))

gnu/packages/samba.scm

@@ -98,14 +98,14 @@ (define (copy dir)
 (define-public samba
   (package
     (name "samba")
-    (version "4.5.0")
+    (version "4.5.1")
     (source (origin
              (method url-fetch)
-             (uri (string-append "https://download.samba.org/pub/samba/stable/samba-"
+             (uri (string-append "https://download.samba.org/pub/samba/stable/"
-                                 version ".tar.gz"))
+                                 "samba-" version ".tar.gz"))
              (sha256
               (base32
-               "11mmyqag2i4yy6dikcggw776n0laxxr0rxhry72x5pa6nwws9afk"))))
+               "11ghsfvqxzfv8gnl62jfnpil9cwd04gak8sx5qcg6zv7d7h079xh"))))
     (build-system gnu-build-system)
     (arguments
      '(#:phases

gnu/packages/version-control.scm

@@ -112,14 +112,14 @@ (define-public bazaar
 (define-public git
   (package
    (name "git")
-   (version "2.10.1")
+   (version "2.10.2")
    (source (origin
             (method url-fetch)
             (uri (string-append "mirror://kernel.org/software/scm/git/git-"
                                 version ".tar.xz"))
             (sha256
              (base32
-              "1ijd1b6szvfw0dmqa3dz1m5g5hbkl9xkb86a9qcjrz0w0vwjvhx9"))))
+              "0wc64dzcxrzgi6kwcljz6y3cwm3ajdgf6aws7g58azbhvl1jk04l"))))
    (build-system gnu-build-system)
    (native-inputs
     `(("native-perl" ,perl)
@@ -132,7 +132,7 @@ (define-public git
                 version ".tar.xz"))
           (sha256
            (base32
-            "049n4ashc1i0rzg19zw1h4hf1qhv1vhpjr5c3jqdcljj4yp7mzw9"))))))
+            "0vxaz23vf3ki0q5zgn6mxr9x1hjryqn1hsmgyrgdk6h3yqbs7c43"))))))
    (inputs
     `(("curl" ,curl)
       ("expat" ,expat)

gnu/system.scm

@@ -2,6 +2,7 @@
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -99,6 +100,8 @@ (define-module (gnu system)
             boot-parameters?
             boot-parameters-label
             boot-parameters-root-device
+            boot-parameters-store-device
+            boot-parameters-store-mount-point
             boot-parameters-kernel
             boot-parameters-kernel-arguments
             boot-parameters-initrd
@@ -728,6 +731,12 @@ (define* (operating-system-grub.cfg os #:optional (old-entries '()))
                            (file-system-device root-fs)))
        (entries ->  (list (menu-entry
                            (label label)
+
+                           ;; The device where the kernel and initrd live.
+                           (device (file-system-device store-fs))
+                           (device-mount-point
+                            (file-system-mount-point store-fs))
+
                            (linux kernel)
                            (linux-arguments
                             (cons* (string-append "--root=" root-device)
@@ -736,8 +745,7 @@ (define* (operating-system-grub.cfg os #:optional (old-entries '()))
                                                     "/boot")
                                    (operating-system-kernel-arguments os)))
                            (initrd initrd)))))
-    (grub-configuration-file (operating-system-bootloader os)
+    (grub-configuration-file (operating-system-bootloader os) entries
-                             store-fs entries
                              #:old-entries old-entries)))
 
 (define (operating-system-parameters-file os)
@@ -745,16 +753,24 @@ (define (operating-system-parameters-file os)
 this file is the reconstruction of GRUB menu entries for old configurations."
   (mlet %store-monad ((initrd   (operating-system-initrd-file os))
                       (root ->  (operating-system-root-file-system os))
+                      (store -> (operating-system-store-file-system os))
                       (label -> (kernel->grub-label
                                  (operating-system-kernel os))))
     (gexp->file "parameters"
-                #~(boot-parameters (version 0)
+                #~(boot-parameters
-                                   (label #$label)
+                   (version 0)
-                                   (root-device #$(file-system-device root))
+                   (label #$label)
-                                   (kernel #$(operating-system-kernel-file os))
+                   (root-device #$(file-system-device root))
-                                   (kernel-arguments
+                   (kernel #$(operating-system-kernel-file os))
-                                    #$(operating-system-kernel-arguments os))
+                   (kernel-arguments
-                                   (initrd #$initrd))
+                    #$(operating-system-kernel-arguments os))
+                   (initrd #$initrd)
+                   (store
+                    (device #$(case (file-system-title store)
+                                ((uuid) (file-system-device store))
+                                ((label) (file-system-device store))
+                                (else #f)))
+                    (mount-point #$(file-system-mount-point store))))
                 #:set-load-path? #f)))
 
 
@@ -765,7 +781,16 @@ (define (operating-system-parameters-file os)
 (define-record-type* <boot-parameters>
   boot-parameters make-boot-parameters boot-parameters?
   (label            boot-parameters-label)
+  ;; Because we will use the 'store-device' to create the GRUB search command,
+  ;; the 'store-device' has slightly different semantics than 'root-device'.
+  ;; The 'store-device' can be a file system uuid, a file system label, or #f,
+  ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not
+  ;; understand that.  The 'root-device', on the other hand, corresponds
+  ;; exactly to the device field of the <file-system> object representing the
+  ;; OS's root file system, so it might be a device path like "/dev/sda3".
   (root-device      boot-parameters-root-device)
+  (store-device     boot-parameters-store-device)
+  (store-mount-point boot-parameters-store-mount-point)
   (kernel           boot-parameters-kernel)
   (kernel-arguments boot-parameters-kernel-arguments)
   (initrd           boot-parameters-initrd))
@@ -799,7 +824,21 @@ (define (read-boot-parameters port)
          (('initrd ('string-append directory file)) ;the old format
           (string-append directory file))
          (('initrd (? string? file))
-          file)))))
+          file)))
+
+      (store-device
+       (match (assq 'store rest)
+         (('store ('device device) _ ...)
+          device)
+         (_                                       ;the old format
+          root)))
+
+      (store-mount-point
+       (match (assq 'store rest)
+         (('store ('device _) ('mount-point mount-point) _ ...)
+          mount-point)
+         (_                                       ;the old format
+          "/")))))
     (x                                            ;unsupported format
      (warning (_ "unrecognized boot parameters for '~a'~%")
               system)

gnu/system/grub.scm

@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -32,6 +33,7 @@ (define-module (gnu system grub)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
+  #:use-module (rnrs bytevectors)
   #:export (grub-image
             grub-image?
             grub-image-aspect-ratio
@@ -61,16 +63,15 @@ (define-module (gnu system grub)
 ;;;
 ;;; Code:
 
-(define (strip-mount-point fs file)
+(define (strip-mount-point mount-point file)
-  "Strip the mount point of FS from FILE, which is a gexp or other lowerable
+  "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object
-object denoting a file name."
+denoting a file name."
-  (let ((mount-point (file-system-mount-point fs)))
+  (if (string=? mount-point "/")
-    (if (string=? mount-point "/")
+      file
-	file
+      #~(let ((file #$file))
-	#~(let ((file #$file))
+          (if (string-prefix? #$mount-point file)
-            (if (string-prefix? #$mount-point file)
+              (substring #$file #$(string-length mount-point))
-                (substring #$file #$(string-length mount-point))
+              file))))
-                file)))))
 
 (define-record-type* <grub-image>
   grub-image make-grub-image
@@ -121,6 +122,10 @@ (define-record-type* <menu-entry>
   menu-entry make-menu-entry
   menu-entry?
   (label           menu-entry-label)
+  (device          menu-entry-device       ; file system uuid, label, or #f
+                   (default #f))
+  (device-mount-point menu-entry-device-mount-point
+                      (default "/"))
   (linux           menu-entry-linux)
   (linux-arguments menu-entry-linux-arguments
                    (default '()))          ; list of string-valued gexps
@@ -162,12 +167,14 @@ (define* (grub-background-image config #:key (width 1024) (height 768))
         (with-monad %store-monad
           (return #f)))))
 
-(define (eye-candy config root-fs system port)
+(define* (eye-candy config store-device store-mount-point
+                    #:key system port)
   "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the
 'grub.cfg' part concerned with graphics mode, background images, colors, and
-all that.  ROOT-FS is a file-system object denoting the root file system where
+all that.  STORE-DEVICE designates the device holding the store, and
-the store is.  SYSTEM must be the target system string---e.g.,
+STORE-MOUNT-POINT is its mount point; these are used to determine where the
-\"x86_64-linux\"."
+background image and fonts must be searched for.  SYSTEM must be the target
+system string---e.g., \"x86_64-linux\"."
   (define setup-gfxterm-body
     ;; Intel systems need to be switched into graphics mode, whereas most
     ;; other modern architectures have no other mode and therefore don't need
@@ -191,7 +198,7 @@ (define (theme-colors type)
                      (symbol->string (assoc-ref colors 'bg)))))
 
   (define font-file
-    (strip-mount-point root-fs
+    (strip-mount-point store-mount-point
                        (file-append grub "/share/grub/unicode.pf2")))
 
   (mlet* %store-monad ((image (grub-background-image config)))
@@ -215,10 +222,10 @@ (define font-file
   set menu_color_highlight=white/blue
 fi~%"
                            #$setup-gfxterm-body
-                           #$(grub-root-search root-fs font-file)
+                           #$(grub-root-search store-device font-file)
                            #$font-file
 
-                           #$(strip-mount-point root-fs image)
+                           #$(strip-mount-point store-mount-point image)
                            #$(theme-colors grub-theme-color-normal)
                            #$(theme-colors grub-theme-color-highlight))))))
 
@@ -227,8 +234,8 @@ (define font-file
 ;;; Configuration file.
 ;;;
 
-(define (grub-root-search root-fs file)
+(define (grub-root-search device file)
-  "Return the GRUB 'search' command to look for ROOT-FS, which contains FILE,
+  "Return the GRUB 'search' command to look for DEVICE, which contains FILE,
 a gexp.  The result is a gexp that can be inserted in the grub.cfg-generation
 code."
   ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but
@@ -236,20 +243,18 @@ (define (grub-root-search root-fs file)
   ;; custom menu entries.  In the latter case, don't emit a 'search' command.
   (if (and (string? file) (not (string-prefix? "/" file)))
       ""
-      (case (file-system-title root-fs)
+      (match device
-        ;; Preferably refer to ROOT-FS by its UUID or label.  This is more
+        ;; Preferably refer to DEVICE by its UUID or label.  This is more
         ;; efficient and less ambiguous, see <>.
-        ((uuid)
+        ((? bytevector? uuid)
          (format #f "search --fs-uuid --set ~a"
-                 (uuid->string (file-system-device root-fs))))
+                 (uuid->string device)))
-        ((label)
+        ((? string? label)
-         (format #f "search --label --set ~a"
+         (format #f "search --label --set ~a" label))
-                 (file-system-device root-fs)))
+        (#f
-        (else
-         ;; As a last resort, look for any device containing FILE.
          #~(format #f "search --file --set ~a" #$file)))))
 
-(define* (grub-configuration-file config store-fs entries
+(define* (grub-configuration-file config entries
                                   #:key
                                   (system (%current-system))
                                   (old-entries '()))
@@ -262,22 +267,30 @@ (define all-entries
 
   (define entry->gexp
     (match-lambda
-     (($ <menu-entry> label linux arguments initrd)
+     (($ <menu-entry> label device device-mount-point
-      ;; Use the right file names for LINUX and STORE-FS in case STORE-FS is
+                      linux arguments initrd)
-      ;; not the "/" file system.
+      ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
-      (let ((linux  (strip-mount-point store-fs linux))
+      ;; Use the right file names for LINUX and INITRD in case
-            (initrd (strip-mount-point store-fs initrd)))
+      ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
+      ;; separate partition.
+      (let ((linux  (strip-mount-point device-mount-point linux))
+            (initrd (strip-mount-point device-mount-point initrd)))
         #~(format port "menuentry ~s {
   ~a
   linux ~a ~a
   initrd ~a
 }~%"
                   #$label
-                  #$(grub-root-search store-fs linux)
+                  #$(grub-root-search device linux)
                   #$linux (string-join (list #$@arguments))
                   #$initrd)))))
 
-  (mlet %store-monad ((sugar (eye-candy config store-fs system #~port)))
+  (mlet %store-monad ((sugar (eye-candy config
+                                        (menu-entry-device (first entries))
+                                        (menu-entry-device-mount-point
+                                         (first entries))
+                                        #:system system
+                                        #:port #~port)))
     (define builder
       #~(call-with-output-file #$output
           (lambda (port)

guix/profiles.scm

@@ -490,12 +490,12 @@ (define (find-among-inputs inputs)
             inputs))
     (define (find-among-store-items items)
       (find (lambda (item)
-              (let-values (((pkg-name pkg-version)
+              (let-values (((name* version*)
                             (package-name->name+version
                              (store-path-package-name item))))
-                (and (equal? name pkg-name)
+                (and (string=? name name*)
                      (if version
-                         (string-prefix? version pkg-version)
+                         (string-prefix? version version*)
                          #t))))
             items))
 

guix/scripts/system.scm

@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -384,6 +385,8 @@ (define (system->grub-entry system number time)
         (label (string-append label " (#"
                               (number->string number) ", "
                               (seconds->string time) ")"))
+        (device (boot-parameters-store-device params))
+        (device-mount-point (boot-parameters-store-mount-point params))
         (linux kernel)
         (linux-arguments
          (cons* (string-append "--root=" root-device)