summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/guix.texi27
-rw-r--r--gnu/local.mk1
-rw-r--r--gnu/packages/emacs.scm4
-rw-r--r--gnu/packages/image.scm19
-rw-r--r--gnu/packages/libusb.scm11
-rw-r--r--gnu/packages/networking.scm34
-rw-r--r--gnu/packages/package-management.scm22
-rw-r--r--gnu/packages/patches/libtiff-CVE-2016-5652.patch47
-rw-r--r--gnu/packages/python.scm29
-rw-r--r--gnu/packages/samba.scm8
-rw-r--r--gnu/packages/version-control.scm6
-rw-r--r--gnu/system.scm59
-rw-r--r--gnu/system/grub.scm85
-rw-r--r--guix/profiles.scm6
-rw-r--r--guix/scripts/system.scm3
15 files changed, 286 insertions, 75 deletions
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 <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 @@
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>
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 @@ 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 <ludo@gnu.org>
+;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; 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>
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
- (($ <menu-entry> 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)))
+ (($ <menu-entry> 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 <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 @@ 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)
generated by cgit v1.2.3 (git 2.25.4) at 2024-07-01 11:05:56 +0000