diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/examples/vm-image.tmpl | 24 | ||||
| -rw-r--r-- | gnu/system/install.scm | 3 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 89 | ||||
| -rw-r--r-- | gnu/system/locale.scm | 72 | ||||
| -rw-r--r-- | gnu/system/pam.scm | 69 | ||||
| -rw-r--r-- | gnu/system/uuid.scm | 4 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 69 |
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)))))) |