diff --git a/doc/guix.texi b/doc/guix.texi index 9df49185ad..70dbc0ac92 100644 --- a/doc/guix.texi +++ b/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 diff --git a/gnu/local.mk b/gnu/local.mk index 39950b0de9..7937809c3c 100644 --- a/gnu/local.mk +++ b/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 \ diff --git a/gnu/packages/emacs.scm b/gnu/packages/emacs.scm index 7c147845fd..2c76b46e54 100644 --- a/gnu/packages/emacs.scm +++ b/gnu/packages/emacs.scm @@ -1652,14 +1652,14 @@ source code using 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))) diff --git a/gnu/packages/image.scm b/gnu/packages/image.scm index 43e8622c76..6cfc6e5be1 100644 --- a/gnu/packages/image.scm +++ b/gnu/packages/image.scm @@ -186,6 +186,7 @@ extracting icontainer icon files.") (define-public libtiff (package (name "libtiff") + (replacement libtiff/fixed) (version "4.0.6") (source (origin (method url-fetch) @@ -225,6 +226,24 @@ collection of tools for doing simple manipulations of TIFF images.") "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") diff --git a/gnu/packages/libusb.scm b/gnu/packages/libusb.scm index fe1bed1768..2c66eca372 100644 --- a/gnu/packages/libusb.scm +++ b/gnu/packages/libusb.scm @@ -105,7 +105,8 @@ version of libusb to run with newer libusb.") (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 @@ version of libusb to run with newer libusb.") (("lib = locate_library\\(candidates, find_library\\)") (string-append "lib = \"" - (car (find-files (assoc-ref inputs "libusb") - (lambda (file stat) - (and ((file-name-predicate - "^libusb-.*\\.so\\..*") file stat) - (not (symbolic-link? file)))))) + (find (negate symbolic-link?) + (find-files (assoc-ref inputs "libusb") + "^libusb-.*\\.so\\..*")) "\""))) #t))))) (inputs diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm index a348d07609..1bcdecf22a 100644 --- a/gnu/packages/networking.scm +++ b/gnu/packages/networking.scm @@ -991,3 +991,37 @@ the bandwidth, loss, and other parameters.") 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+))) diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index 591f60307e..7c1ba846c9 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -159,7 +159,17 @@ #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 @@ the Nix package manager.") (chmod po #o666)) (find-files "." "\\.po$")) - (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)))))) + (zero? (system* "sh" "bootstrap"))))))))))) (define-public guix guix-devel) diff --git a/gnu/packages/patches/libtiff-CVE-2016-5652.patch b/gnu/packages/patches/libtiff-CVE-2016-5652.patch new file mode 100644 index 0000000000..54b87d0185 --- /dev/null +++ b/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, diff --git a/gnu/packages/python.scm b/gnu/packages/python.scm index 9c7320f41e..5df774fd10 100644 --- a/gnu/packages/python.scm +++ b/gnu/packages/python.scm @@ -5307,7 +5307,7 @@ connection to each user.") (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 @@ useful as a validator for JSON data.") (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)))))) diff --git a/gnu/packages/samba.scm b/gnu/packages/samba.scm index 45fa47b3c8..1706ec3030 100644 --- a/gnu/packages/samba.scm +++ b/gnu/packages/samba.scm @@ -98,14 +98,14 @@ anywhere.") (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-" - version ".tar.gz")) + (uri (string-append "https://download.samba.org/pub/samba/stable/" + "samba-" version ".tar.gz")) (sha256 (base32 - "11mmyqag2i4yy6dikcggw776n0laxxr0rxhry72x5pa6nwws9afk")))) + "11ghsfvqxzfv8gnl62jfnpil9cwd04gak8sx5qcg6zv7d7h079xh")))) (build-system gnu-build-system) (arguments '(#:phases diff --git a/gnu/packages/version-control.scm b/gnu/packages/version-control.scm index 4ca5a97311..1f7d60148c 100644 --- a/gnu/packages/version-control.scm +++ b/gnu/packages/version-control.scm @@ -112,14 +112,14 @@ as well as the classic centralized workflow.") (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 @@ as well as the classic centralized workflow.") version ".tar.xz")) (sha256 (base32 - "049n4ashc1i0rzg19zw1h4hf1qhv1vhpjr5c3jqdcljj4yp7mzw9")))))) + "0vxaz23vf3ki0q5zgn6mxr9x1hjryqn1hsmgyrgdk6h3yqbs7c43")))))) (inputs `(("curl" ,curl) ("expat" ,expat) diff --git a/gnu/system.scm b/gnu/system.scm index 43117b1714..5cb09b7880 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015, 2016 Alex Kost +;;; Copyright © 2016 Chris Marusich ;;; ;;; This file is part of GNU Guix. ;;; @@ -99,6 +100,8 @@ 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 @@ listed in OS. The C library expects to find it under (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 @@ listed in OS. The C library expects to find it under "/boot") (operating-system-kernel-arguments os))) (initrd initrd))))) - (grub-configuration-file (operating-system-bootloader os) - store-fs entries + (grub-configuration-file (operating-system-bootloader os) entries #:old-entries old-entries))) (define (operating-system-parameters-file os) @@ -745,16 +753,24 @@ listed in OS. The C library expects to find it under 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) - (label #$label) - (root-device #$(file-system-device root)) - (kernel #$(operating-system-kernel-file os)) - (kernel-arguments - #$(operating-system-kernel-arguments os)) - (initrd #$initrd)) + #~(boot-parameters + (version 0) + (label #$label) + (root-device #$(file-system-device root)) + (kernel #$(operating-system-kernel-file os)) + (kernel-arguments + #$(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 @@ this file is the reconstruction of GRUB menu entries for old configurations." (define-record-type* 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 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 @@ this file is the reconstruction of GRUB menu entries for old configurations." (('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) diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 249b415ab4..5c9d0f15a1 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2016 Chris Marusich ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ #: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 @@ ;;; ;;; Code: -(define (strip-mount-point fs file) - "Strip the mount point of FS from FILE, which is a gexp or other lowerable -object denoting a file name." - (let ((mount-point (file-system-mount-point fs))) - (if (string=? mount-point "/") - file - #~(let ((file #$file)) - (if (string-prefix? #$mount-point file) - (substring #$file #$(string-length mount-point)) - file))))) +(define (strip-mount-point mount-point file) + "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object +denoting a file name." + (if (string=? mount-point "/") + file + #~(let ((file #$file)) + (if (string-prefix? #$mount-point file) + (substring #$file #$(string-length mount-point)) + file)))) (define-record-type* grub-image make-grub-image @@ -121,6 +122,10 @@ object denoting a file name." 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 @@ WIDTH/HEIGHT, or #f if none was found." (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 -the store is. SYSTEM must be the target system string---e.g., -\"x86_64-linux\"." +all that. STORE-DEVICE designates the device holding the store, and +STORE-MOUNT-POINT is its mount point; these are used to determine where the +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 @@ the store is. SYSTEM must be the target system string---e.g., (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 @@ else 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 @@ fi~%" ;;; Configuration file. ;;; -(define (grub-root-search root-fs file) - "Return the GRUB 'search' command to look for ROOT-FS, which contains FILE, +(define (grub-root-search device 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 @@ code." ;; 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) - ;; Preferably refer to ROOT-FS by its UUID or label. This is more + (match device + ;; 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)))) - ((label) - (format #f "search --label --set ~a" - (file-system-device root-fs))) - (else - ;; As a last resort, look for any device containing FILE. + (uuid->string device))) + ((? string? label) + (format #f "search --label --set ~a" label)) + (#f #~(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 @@ corresponding to old generations of the system." (define entry->gexp (match-lambda - (($ label linux arguments initrd) - ;; Use the right file names for LINUX and STORE-FS in case STORE-FS is - ;; not the "/" file system. - (let ((linux (strip-mount-point store-fs linux)) - (initrd (strip-mount-point store-fs initrd))) + (($ label device device-mount-point + linux arguments initrd) + ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point. + ;; Use the right file names for LINUX and INITRD in case + ;; 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) diff --git a/guix/profiles.scm b/guix/profiles.scm index d162f6241b..6a9e570a3f 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -490,12 +490,12 @@ if not found." 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)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 0519ab8c0b..e548be649d 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2016 Alex Kost +;;; Copyright © 2016 Chris Marusich ;;; ;;; This file is part of GNU Guix. ;;; @@ -384,6 +385,8 @@ it atomically, and then run OS's activation script." (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)