mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
Merge branch 'master' into core-updates
This commit is contained in:
commit
205f0107bb
15 changed files with 286 additions and 75 deletions
|
@ -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
|
||||
|
||||
|
|
|
@ -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 \
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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")
|
||||
|
|
|
@ -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")
|
||||
(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
|
||||
|
|
|
@ -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+)))
|
||||
|
|
|
@ -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"))))))))
|
||||
(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)
|
||||
|
||||
|
|
47
gnu/packages/patches/libtiff-CVE-2016-5652.patch
Normal file
47
gnu/packages/patches/libtiff-CVE-2016-5652.patch
Normal file
|
@ -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,
|
|
@ -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))))))
|
||||
|
|
|
@ -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-"
|
||||
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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
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 @@ (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
|
||||
(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))
|
||||
(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)
|
||||
|
|
|
@ -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)
|
||||
"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)))
|
||||
(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)))))
|
||||
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
|
||||
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 @@ (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)
|
||||
"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 @@ (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)
|
||||
;; 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 @@ (define all-entries
|
|||
|
||||
(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)
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in a new issue