summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/examples/vm-image.tmpl24
-rw-r--r--gnu/system/install.scm3
-rw-r--r--gnu/system/linux-container.scm89
-rw-r--r--gnu/system/locale.scm72
-rw-r--r--gnu/system/pam.scm69
-rw-r--r--gnu/system/uuid.scm4
-rw-r--r--gnu/system/vm.scm69
7 files changed, 251 insertions, 79 deletions
diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl
index a140082c0b..7d984155bc 100644
--- a/gnu/system/examples/vm-image.tmpl
+++ b/gnu/system/examples/vm-image.tmpl
@@ -4,9 +4,10 @@
;; guix system reconfigure /etc/config.scm
;;
-(use-modules (gnu) (srfi srfi-1))
+(use-modules (gnu) (guix) (srfi srfi-1))
(use-service-modules desktop networking ssh xorg)
-(use-package-modules bootloaders certs fonts nvi wget xorg)
+(use-package-modules bootloaders certs fonts nvi
+ package-management wget xorg)
(define vm-image-motd (plain-file "motd" "
\x1b[1;37mThis is the GNU system. Welcome!\x1b[0m
@@ -34,6 +35,9 @@ accounts.\x1b[0m
(locale "en_US.utf8")
(keyboard-layout (keyboard-layout "us" "altgr-intl"))
+ ;; Label for the GRUB boot menu.
+ (label (string-append "GNU Guix " (package-version guix)))
+
(firmware '())
;; Below we assume /dev/vda is the VM's hard disk.
@@ -88,14 +92,18 @@ root ALL=(ALL) ALL
;; Use the DHCP client service rather than NetworkManager.
(service dhcp-client-service-type))
- ;; Remove GDM, NetworkManager, and wpa-supplicant, which don't make
- ;; sense in a VM.
+ ;; Remove GDM, ModemManager, NetworkManager, and wpa-supplicant,
+ ;; which don't make sense in a VM.
(remove (lambda (service)
(let ((type (service-kind service)))
- (memq type (list gdm-service-type
- wpa-supplicant-service-type
- cups-pk-helper-service-type
- network-manager-service-type))))
+ (or (memq type
+ (list gdm-service-type
+ wpa-supplicant-service-type
+ cups-pk-helper-service-type
+ network-manager-service-type
+ modem-manager-service-type))
+ (eq? 'network-manager-applet
+ (service-type-name type)))))
(modify-services %desktop-services
(login-service-type config =>
(login-configuration
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 45c6051732..453b0bdd6d 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -85,7 +85,8 @@
'(("de" . "Systeminstallation")
("en" . "System Installation")
("es" . "Instalación del sistema")
- ("fr" . "Installation du système")))
+ ("fr" . "Installation du système")
+ ("ru" . "Установка системы")))
(define (log-to-info tty user)
"Return a script that spawns the Info reader on the right section of the
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index 149c3d08a3..16eee7a3cd 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -35,7 +36,7 @@
containerized-operating-system
container-script))
-(define (container-essential-services os)
+(define* (container-essential-services os #:key shared-network?)
"Return a list of essential services corresponding to OS, a
non-containerized OS. This procedure essentially strips essential services
from OS that are needed on the bare metal and not in a container."
@@ -45,18 +46,32 @@ from OS that are needed on the bare metal and not in a container."
(list (service-kind %linux-bare-metal-service)
firmware-service-type
system-service-type)))
- (operating-system-essential-services os)))
+ (operating-system-default-essential-services os)))
(cons (service system-service-type
(let ((locale (operating-system-locale-directory os)))
(with-monad %store-monad
(return `(("locale" ,locale))))))
- base))
+ ;; If network is to be shared with the host, remove network
+ ;; configuration files from etc-service.
+ (if shared-network?
+ (modify-services base
+ (etc-service-type
+ files => (remove
+ (match-lambda
+ ((filename _)
+ (member filename
+ (map basename %network-configuration-files))))
+ files)))
+ base)))
-(define (containerized-operating-system os mappings)
+(define* (containerized-operating-system os mappings
+ #:key
+ shared-network?
+ (extra-file-systems '()))
"Return an operating system based on OS for use in a Linux container
environment. MAPPINGS is a list of <file-system-mapping> to realize in the
-containerized OS."
+containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
(define user-file-systems
(remove (lambda (fs)
(let ((target (file-system-mount-point fs))
@@ -65,8 +80,8 @@ containerized OS."
(string=? target "/")
(and (string? source)
(string-prefix? "/dev/" source))
- (string-prefix? "/dev" target)
- (string-prefix? "/sys" target))))
+ (string-prefix? "/dev/" target)
+ (string-prefix? "/sys/" target))))
(operating-system-file-systems os)))
(define (mapping->fs fs)
@@ -76,28 +91,63 @@ containerized OS."
(define useless-services
;; Services that make no sense in a container. Those that attempt to
;; access /dev/tty[0-9] in particular cannot work in a container.
- (list console-font-service-type
- mingetty-service-type
- agetty-service-type))
+ (append (list console-font-service-type
+ mingetty-service-type
+ agetty-service-type)
+ ;; Remove nscd service if network is shared with the host.
+ (if shared-network?
+ (list nscd-service-type)
+ (list))))
(operating-system
(inherit os)
(swap-devices '()) ; disable swap
- (essential-services (container-essential-services os))
+ (essential-services (container-essential-services
+ this-operating-system
+ #:shared-network? shared-network?))
(services (remove (lambda (service)
(memq (service-kind service)
useless-services))
(operating-system-user-services os)))
- (file-systems (append (map mapping->fs (cons %store-mapping mappings))
- %container-file-systems
- user-file-systems))))
+ (file-systems (append (map mapping->fs mappings)
+ extra-file-systems
+ user-file-systems
-(define* (container-script os #:key (mappings '()))
+ ;; Provide a dummy root file system so we can create
+ ;; a 'boot-parameters' file.
+ (list (file-system
+ (mount-point "/")
+ (device "nothing")
+ (type "dummy")))))))
+
+(define* (container-script os #:key (mappings '()) shared-network?)
"Return a derivation of a script that runs OS as a Linux container.
MAPPINGS is a list of <file-system> objects that specify the files/directories
that will be shared with the host system."
- (let* ((os (containerized-operating-system os mappings))
- (file-systems (filter file-system-needed-for-boot?
+ (define network-mappings
+ ;; Files to map if network is to be shared with the host
+ (append %network-file-mappings
+ (let ((nscd-run-directory "/var/run/nscd"))
+ (if (file-exists? nscd-run-directory)
+ (list (file-system-mapping
+ (source nscd-run-directory)
+ (target nscd-run-directory)))
+ '()))))
+
+ (define (mountable-file-system? file-system)
+ ;; Return #t if FILE-SYSTEM should be mounted in the container.
+ (and (not (string=? "/" (file-system-mount-point file-system)))
+ (file-system-needed-for-boot? file-system)))
+
+ (let* ((os (containerized-operating-system
+ os
+ (cons %store-mapping
+ (if shared-network?
+ (append network-mappings mappings)
+ mappings))
+ #:shared-network? shared-network?
+ #:extra-file-systems %container-file-systems))
+ (file-systems (filter mountable-file-system?
(operating-system-file-systems os)))
(specs (map file-system->spec file-systems)))
@@ -121,6 +171,9 @@ that will be shared with the host system."
;; users and groups, which is sufficient for most cases.
;;
;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
- #:host-uids 65536))))
+ #:host-uids 65536
+ #:namespaces (if #$shared-network?
+ (delq 'net %namespaces)
+ %namespaces)))))
(gexp->script "run-container" script)))
diff --git a/gnu/system/locale.scm b/gnu/system/locale.scm
index 75417f6698..533a45e149 100644
--- a/gnu/system/locale.scm
+++ b/gnu/system/locale.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -20,6 +20,7 @@
(define-module (gnu system locale)
#:use-module (guix gexp)
#:use-module (guix store)
+ #:use-module (guix modules)
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix utils)
@@ -37,7 +38,9 @@
locale-directory
%default-locale-libcs
- %default-locale-definitions))
+ %default-locale-definitions
+
+ glibc-supported-locales))
;;; Commentary:
;;;
@@ -202,4 +205,69 @@ data format changes between libc versions."
"vi_VN"
"zh_CN"))))
+
+;;;
+;;; Locales supported by glibc.
+;;;
+
+(define* (glibc-supported-locales #:optional (glibc glibc))
+ "Return a file-like object that contains a list of locale name/encoding
+pairs such as (\"oc_FR.UTF-8\" . \"UTF-8\"). Each pair corresponds to a
+locale supported by GLIBC."
+ (define build
+ (with-imported-modules (source-module-closure
+ '((guix build gnu-build-system)))
+ #~(begin
+ (use-modules (guix build gnu-build-system)
+ (srfi srfi-1)
+ (ice-9 rdelim)
+ (ice-9 match)
+ (ice-9 regex)
+ (ice-9 pretty-print))
+
+ (define unpack
+ (assq-ref %standard-phases 'unpack))
+
+ (define locale-rx
+ ;; Regexp matching a locale line in 'localedata/SUPPORTED'.
+ (make-regexp
+ "^[[:space:]]*([[:graph:]]+)/([[:graph:]]+)[[:space:]]*\\\\$"))
+
+ (define (read-supported-locales port)
+ ;; Read the 'localedata/SUPPORTED' file from PORT. That file is
+ ;; actually a makefile snippet, with one locale per line, and a
+ ;; header that can be discarded.
+ (let loop ((locales '()))
+ (define line
+ (read-line port))
+
+ (cond ((eof-object? line)
+ (reverse locales))
+ ((string-prefix? "#" (string-trim line)) ;comment
+ (loop locales))
+ ((string-contains line "=") ;makefile variable assignment
+ (loop locales))
+ (else
+ (match (regexp-exec locale-rx line)
+ (#f
+ (loop locales))
+ (m
+ (loop (alist-cons (match:substring m 1)
+ (match:substring m 2)
+ locales))))))))
+
+ (setenv "PATH"
+ (string-append #+(file-append tar "/bin") ":"
+ #+(file-append xz "/bin") ":"
+ #+(file-append gzip "/bin")))
+ (unpack #:source #+(package-source glibc))
+
+ (let ((locales (call-with-input-file "localedata/SUPPORTED"
+ read-supported-locales)))
+ (call-with-output-file #$output
+ (lambda (port)
+ (pretty-print locales port)))))))
+
+ (computed-file "glibc-supported-locales.scm" build))
+
;;; locale.scm ends here
diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm
index 13f76a50ed..85f75517b1 100644
--- a/gnu/system/pam.scm
+++ b/gnu/system/pam.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -207,40 +207,47 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE."
(env (pam-entry ; to honor /etc/environment.
(control "required")
(module "pam_env.so"))))
- (lambda* (name #:key allow-empty-passwords? (allow-root? #f) motd)
+ (lambda* (name #:key allow-empty-passwords? (allow-root? #f) motd
+ login-uid?)
"Return a standard Unix-style PAM service for NAME. When
ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords. When ALLOW-ROOT? is
true, allow root to run the command without authentication. When MOTD is
-true, it should be a file-like object used as the message-of-the-day."
+true, it should be a file-like object used as the message-of-the-day.
+When LOGIN-UID? is true, require the 'pam_loginuid' module; that module sets
+/proc/self/loginuid, which the libc 'getlogin' function relies on."
;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
- (let ((name* name))
- (pam-service
- (name name*)
- (account (list unix))
- (auth (append (if allow-root?
- (list (pam-entry
- (control "sufficient")
- (module "pam_rootok.so")))
- '())
- (list (if allow-empty-passwords?
- (pam-entry
- (control "required")
- (module "pam_unix.so")
- (arguments '("nullok")))
- unix))))
- (password (list (pam-entry
- (control "required")
- (module "pam_unix.so")
- ;; Store SHA-512 encrypted passwords in /etc/shadow.
- (arguments '("sha512" "shadow")))))
- (session (if motd
- (list env unix
- (pam-entry
- (control "optional")
- (module "pam_motd.so")
- (arguments
- (list #~(string-append "motd=" #$motd)))))
- (list env unix))))))))
+ (pam-service
+ (name name)
+ (account (list unix))
+ (auth (append (if allow-root?
+ (list (pam-entry
+ (control "sufficient")
+ (module "pam_rootok.so")))
+ '())
+ (list (if allow-empty-passwords?
+ (pam-entry
+ (control "required")
+ (module "pam_unix.so")
+ (arguments '("nullok")))
+ unix))))
+ (password (list (pam-entry
+ (control "required")
+ (module "pam_unix.so")
+ ;; Store SHA-512 encrypted passwords in /etc/shadow.
+ (arguments '("sha512" "shadow")))))
+ (session `(,@(if motd
+ (list (pam-entry
+ (control "optional")
+ (module "pam_motd.so")
+ (arguments
+ (list #~(string-append "motd=" #$motd)))))
+ '())
+ ,@(if login-uid?
+ (list (pam-entry ;to fill in /proc/self/loginuid
+ (control "required")
+ (module "pam_loginuid.so")))
+ '())
+ ,env ,unix))))))
(define (rootok-pam-service command)
"Return a PAM service for COMMAND such that 'root' does not need to
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index f13960c3e9..e7a3a0439d 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
;;;
;;; This file is part of GNU Guix.
@@ -175,7 +175,7 @@ ISO9660 UUID representation."
"Convert FAT32/FAT16 UUID, a 4-byte bytevector, to its string representation."
(let ((high (bytevector-uint-ref uuid 0 %fat-endianness 2))
(low (bytevector-uint-ref uuid 2 %fat-endianness 2)))
- (format #f "~:@(~x-~x~)" low high)))
+ (format #f "~:@(~4,'0x-~4,'0x~)" low high)))
(define %fat-uuid-rx
(make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$"))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 92b03b01ad..0d4ed63eec 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -64,6 +64,7 @@
#:use-module (gnu system file-systems)
#:use-module (gnu system)
#:use-module (gnu services)
+ #:use-module (gnu services base)
#:use-module (gnu system uuid)
#:use-module (srfi srfi-1)
@@ -249,6 +250,12 @@ made available under the /xchg CIFS share."
#:guile-for-build guile-for-build
#:references-graphs references-graphs)))
+(define (has-guix-service-type? os)
+ "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
+ (not (not (find (lambda (service)
+ (eq? (service-kind service) guix-service-type))
+ (operating-system-services os)))))
+
(define* (iso9660-image #:key
(name "iso9660-image")
file-system-label
@@ -258,8 +265,9 @@ made available under the /xchg CIFS share."
os
bootcfg-drv
bootloader
- register-closures?
- (inputs '()))
+ (register-closures? (has-guix-service-type? os))
+ (inputs '())
+ (grub-mkrescue-environment '()))
"Return a bootable, stand-alone iso9660 image.
INPUTS is a list of inputs (as for packages)."
@@ -283,6 +291,11 @@ INPUTS is a list of inputs (as for packages)."
(sql-schema #$schema)
+ ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8")
+
(let ((inputs
'#$(append (list qemu parted e2fsprogs dosfstools xorriso)
(map canonical-package
@@ -301,7 +314,9 @@ INPUTS is a list of inputs (as for packages)."
inputs)))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
- (make-iso9660-image #$(bootloader-package bootloader)
+ (make-iso9660-image #$xorriso
+ '#$grub-mkrescue-environment
+ #$(bootloader-package bootloader)
#$bootcfg-drv
#$os
"/xchg/guixsd.iso"
@@ -338,7 +353,7 @@ INPUTS is a list of inputs (as for packages)."
os
bootcfg-drv
bootloader
- (register-closures? #t)
+ (register-closures? (has-guix-service-type? os))
(inputs '())
copy-inputs?)
"Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
@@ -354,7 +369,9 @@ file (GRUB-CONFIGURATION must be the name of a file in the VM.)
INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
register INPUTS in the store database of the image so that Guix can be used in
-the image."
+the image. By default, REGISTER-CLOSURES? is set to true only if a service of
+type GUIX-SERVICE-TYPE is present in the services definition of the operating
+system."
(define schema
(and register-closures?
(local-file (search-path %load-path
@@ -379,6 +396,11 @@ the image."
(sql-schema #$schema)
+ ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8")
+
(let ((inputs
'#$(append (list qemu parted e2fsprogs dosfstools)
(map canonical-package
@@ -463,21 +485,32 @@ the image."
(define* (system-docker-image os
#:key
- (name "guixsd-docker-image")
- register-closures?)
+ (name "guix-docker-image")
+ (register-closures? (has-guix-service-type? os)))
"Build a docker image. OS is the desired <operating-system>. NAME is the
-base name to use for the output file. When REGISTER-CLOSURES? is not #f,
-register the closure of OS with Guix in the resulting Docker image. This only
-makes sense when you want to build a Guix System Docker image that has Guix
-installed inside of it. If you don't need Guix (e.g., your Docker
-image just contains a web server that is started by the Shepherd), then you
-should set REGISTER-CLOSURES? to #f."
+base name to use for the output file. When REGISTER-CLOSURES? is true,
+register the closure of OS with Guix in the resulting Docker image. By
+default, REGISTER-CLOSURES? is set to true only if a service of type
+GUIX-SERVICE-TYPE is present in the services definition of the operating
+system."
(define schema
(and register-closures?
(local-file (search-path %load-path
"guix/store/schema.sql"))))
- (let ((os (containerized-operating-system os '()))
+ (define boot-program
+ ;; Program that runs the boot script of OS, which in turn starts shepherd.
+ (program-file "boot-program"
+ #~(let ((system (cadr (command-line))))
+ (setenv "GUIX_NEW_SYSTEM" system)
+ (execl #$(file-append guile-2.2 "/bin/guile")
+ "guile" "--no-auto-compile"
+ (string-append system "/boot")))))
+
+
+ (let ((os (operating-system-with-gc-roots
+ (containerized-operating-system os '())
+ (list boot-program)))
(name (string-append name ".tar.gz"))
(graph "system-graph"))
(define build
@@ -528,9 +561,11 @@ should set REGISTER-CLOSURES? to #f."
(string-append "/xchg/" #$graph)
read-reference-graph)))
#$os
+ #:entry-point '(#$boot-program #$os)
#:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
#:creation-time (make-time time-utc 0 1)
#:transformations `((,root-directory -> ""))))))))
+
(expression->derivation-in-linux-vm
name build
#:make-disk-image? #f
@@ -668,12 +703,13 @@ to USB sticks meant to be read-only."
#:file-system-label root-label
#:file-system-uuid uuid
#:os os
- #:register-closures? #t
#:bootcfg-drv bootcfg
#:bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os))
#:inputs `(("system" ,os)
- ("bootcfg" ,bootcfg)))
+ ("bootcfg" ,bootcfg))
+ #:grub-mkrescue-environment
+ '(("MKRESCUE_SED_MODE" . "mbr_hfs")))
(qemu-image #:name name
#:os os
#:bootcfg-drv bootcfg
@@ -685,7 +721,6 @@ to USB sticks meant to be read-only."
#:file-system-label root-label
#:file-system-uuid uuid
#:copy-inputs? #t
- #:register-closures? #t
#:inputs `(("system" ,os)
("bootcfg" ,bootcfg))))))
generated by cgit v1.2.3 (git 2.45.2) at 2024-09-02 15:52:50 +0000