diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/examples/bare-bones.tmpl | 2 | ||||
| -rw-r--r-- | gnu/system/examples/desktop.tmpl | 2 | ||||
| -rw-r--r-- | gnu/system/examples/lightweight-desktop.tmpl | 2 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 94 | ||||
| -rw-r--r-- | gnu/system/grub.scm | 8 | ||||
| -rw-r--r-- | gnu/system/install.scm | 4 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 21 | ||||
| -rw-r--r-- | gnu/system/mapped-devices.scm | 2 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 38 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 2 |
10 files changed, 137 insertions, 38 deletions
diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index 87e8d1e93c..222ddda579 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -8,7 +8,7 @@ (operating-system (host-name "komputilo") (timezone "Europe/Berlin") - (locale "en_US.UTF-8") + (locale "en_US.utf8") ;; Assuming /dev/sdX is the target hard disk, and "my-root" is ;; the label of the target root file system. diff --git a/gnu/system/examples/desktop.tmpl b/gnu/system/examples/desktop.tmpl index 21b4563b53..8b02659478 100644 --- a/gnu/system/examples/desktop.tmpl +++ b/gnu/system/examples/desktop.tmpl @@ -9,7 +9,7 @@ (operating-system (host-name "antelope") (timezone "Europe/Paris") - (locale "en_US.UTF-8") + (locale "en_US.utf8") ;; Assuming /dev/sdX is the target hard disk, and "my-root" ;; is the label of the target root file system. diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl index 91e7d0b562..131c43af77 100644 --- a/gnu/system/examples/lightweight-desktop.tmpl +++ b/gnu/system/examples/lightweight-desktop.tmpl @@ -9,7 +9,7 @@ (operating-system (host-name "antelope") (timezone "Europe/Paris") - (locale "en_US.UTF-8") + (locale "en_US.utf8") ;; Assuming /dev/sdX is the target hard disk, and "my-root" ;; is the label of the target root file system. diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 4cc1221eb8..7011a279d3 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,8 +18,8 @@ (define-module (gnu system file-systems) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (guix records) - #:use-module (guix store) #:use-module ((gnu build file-systems) #:select (string->uuid uuid->string)) #:re-export (string->uuid @@ -63,7 +63,11 @@ file-system-mapping-target file-system-mapping-writable? - %store-mapping)) + file-system-mapping->bind-mount + + %store-mapping + %network-configuration-files + %network-file-mappings)) ;;; Commentary: ;;; @@ -95,11 +99,53 @@ (dependencies file-system-dependencies ; list of <file-system> (default '()))) ; or <mapped-device> -(define-inlinable (file-system-needed-for-boot? fs) - "Return true if FS has the 'needed-for-boot?' flag set, or if it's the root -file system." +;; Note: This module is used both on the build side and on the host side. +;; Arrange not to pull (guix store) and (guix config) because the latter +;; differs from user to user. +(define (%store-prefix) + "Return the store prefix." + (cond ((resolve-module '(guix store) #:ensure #f) + => + (lambda (store) + ((module-ref store '%store-prefix)))) + ((getenv "NIX_STORE") + => identity) + (else + "/gnu/store"))) + +(define %not-slash + (char-set-complement (char-set #\/))) + +(define (file-prefix? file1 file2) + "Return #t if FILE1 denotes the name of a file that is a parent of FILE2, +where both FILE1 and FILE2 are absolute file name. For example: + + (file-prefix? \"/gnu\" \"/gnu/store\") + => #t + + (file-prefix? \"/gn\" \"/gnu/store\") + => #f +" + (and (string-prefix? "/" file1) + (string-prefix? "/" file2) + (let loop ((file1 (string-tokenize file1 %not-slash)) + (file2 (string-tokenize file2 %not-slash))) + (match file1 + (() + #t) + ((head1 tail1 ...) + (match file2 + ((head2 tail2 ...) + (and (string=? head1 head2) (loop tail1 tail2))) + (() + #f))))))) + +(define (file-system-needed-for-boot? fs) + "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the +store--e.g., if FS is the root file system." (or (%file-system-needed-for-boot? fs) - (string=? "/" (file-system-mount-point fs)))) + (and (file-prefix? (file-system-mount-point fs) (%store-prefix)) + (not (memq 'bind-mount (file-system-flags fs)))))) (define (file-system->spec fs) "Return a list corresponding to file-system FS that can be passed to the @@ -324,6 +370,21 @@ TARGET in the other system." (writable? file-system-mapping-writable? ;Boolean (default #f))) +(define (file-system-mapping->bind-mount mapping) + "Return a file system that realizes MAPPING, a <file-system-mapping>, using +a bind mount." + (match mapping + (($ <file-system-mapping> source target writable?) + (file-system + (mount-point target) + (device source) + (type "none") + (flags (if writable? + '(bind-mount) + '(bind-mount read-only))) + (check? #f) + (create-mount-point? #t))))) + (define %store-mapping ;; Mapping of the host's store into the guest. (file-system-mapping @@ -331,4 +392,23 @@ TARGET in the other system." (target (%store-prefix)) (writable? #f))) +(define %network-configuration-files + ;; List of essential network configuration files. + '("/etc/resolv.conf" + "/etc/nsswitch.conf" + "/etc/services" + "/etc/hosts")) + +(define %network-file-mappings + ;; List of file mappings for essential network files. + (filter-map (lambda (file) + (file-system-mapping + (source file) + (target file) + ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a + ;; symlink to a file in a tmpfs which, for an unknown reason, + ;; cannot be bind mounted read-only within the container. + (writable? (string=? file "/etc/resolv.conf")))) + %network-configuration-files)) + ;;; file-systems.scm ends here diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 067b291a5c..b18b8be6d7 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -27,7 +27,7 @@ #:use-module (guix download) #:use-module (gnu artwork) #:use-module (gnu system file-systems) - #:autoload (gnu packages grub) (grub) + #:autoload (gnu packages bootloaders) (grub) #:autoload (gnu packages compression) (gzip) #:autoload (gnu packages gtk) (guile-cairo guile-rsvg) #:use-module (ice-9 match) @@ -94,8 +94,8 @@ denoting a file name." (define %background-image (grub-image (aspect-ratio 4/3) - (file #~(string-append #$%artwork-repository - "/grub/GuixSD-fully-black-4-3.svg")))) + (file (file-append %artwork-repository + "/grub/GuixSD-fully-black-4-3.svg")))) (define %default-theme ;; Default theme contributed by Felipe López. @@ -108,7 +108,7 @@ denoting a file name." grub-configuration make-grub-configuration grub-configuration? (grub grub-configuration-grub ; package - (default (@ (gnu packages grub) grub))) + (default (@ (gnu packages bootloaders) grub))) (device grub-configuration-device) ; string (menu-entries grub-configuration-menu-entries ; list (default '())) diff --git a/gnu/system/install.scm b/gnu/system/install.scm index ad234fd9c1..3ec343570a 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -28,11 +28,11 @@ #:use-module (gnu services shepherd) #:use-module (gnu packages admin) #:use-module (gnu packages bash) + #:use-module (gnu packages bootloaders) #:use-module (gnu packages linux) #:use-module (gnu packages cryptsetup) #:use-module (gnu packages package-management) #:use-module (gnu packages disk) - #:use-module (gnu packages grub) #:use-module (gnu packages texinfo) #:use-module (gnu packages compression) #:use-module (gnu packages nvi) @@ -388,7 +388,7 @@ Use Alt-F2 for documentation. (base-pam-services #:allow-empty-passwords? #t)) (packages (cons* (canonical-package glibc) ;for 'tzselect' & co. - parted ddrescue + parted gptfdisk ddrescue grub ;mostly so xrefs to its manual work cryptsetup mdadm diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 24e61c3ead..bceea41332 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,25 +30,10 @@ #:use-module (gnu services) #:use-module (gnu system) #:use-module (gnu system file-systems) - #:export (mapping->file-system - system-container + #:export (system-container containerized-operating-system container-script)) -(define (mapping->file-system mapping) - "Return a file system that realizes MAPPING." - (match mapping - (($ <file-system-mapping> source target writable?) - (file-system - (mount-point target) - (device source) - (type "none") - (flags (if writable? - '(bind-mount) - '(bind-mount read-only))) - (check? #f) - (create-mount-point? #t))))) - (define (containerized-operating-system os mappings) "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 @@ -66,7 +51,7 @@ containerized OS." (operating-system-file-systems os))) (define (mapping->fs fs) - (file-system (inherit (mapping->file-system fs)) + (file-system (inherit (file-system-mapping->bind-mount fs)) (needed-for-boot? #t))) (operating-system (inherit os) diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 8ab861bf73..2959802c96 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -54,7 +54,7 @@ (define-record-type* <mapped-device> mapped-device make-mapped-device mapped-device? - (source mapped-device-source) ;string + (source mapped-device-source) ;string | list of strings (target mapped-device-target) ;string (type mapped-device-type)) ;<mapped-device-kind> diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index cfdcf5e136..1acfcc4866 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -21,9 +21,11 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix store) + #:use-module (guix modules) #:use-module (guix sets) #:use-module (guix ui) #:use-module (gnu services) + #:use-module (gnu services shepherd) #:use-module ((gnu system file-systems) #:select (%tty-gid)) #:use-module ((gnu packages admin) @@ -43,6 +45,7 @@ user-account-supplementary-groups user-account-comment user-account-home-directory + user-account-create-home-directory? user-account-shell user-account-system? @@ -81,7 +84,7 @@ (create-home-directory? user-account-create-home-directory? ;Boolean (default #t)) (shell user-account-shell ; gexp - (default #~(string-append #$bash "/bin/bash"))) + (default (file-append bash "/bin/bash"))) (system? user-account-system? ; Boolean (default #f))) @@ -128,7 +131,7 @@ (name "nobody") (uid 65534) (group "nogroup") - (shell #~(string-append #$shadow "/sbin/nologin")) + (shell (file-append shadow "/sbin/nologin")) (home-directory "/nonexistent") (create-home-directory? #f) (system? #t)))) @@ -288,6 +291,35 @@ group." (activate-users+groups (list #$@user-specs) (list #$@group-specs)))) +(define (account-shepherd-service accounts+groups) + "Return a Shepherd service that creates the home directories for the user +accounts among ACCOUNTS+GROUPS." + (define accounts + (filter user-account? accounts+groups)) + + ;; Create home directories only once 'file-systems' is up. This makes sure + ;; they are created in the right place if /home lives on a separate + ;; partition. + ;; + ;; XXX: We arrange for this service to stop right after it's done its job so + ;; that 'guix system reconfigure' knows that it can reload it fearlessly + ;; (and thus create new home directories). The cost of this hack is that + ;; there's a small window during which first-time logins could happen before + ;; the home directory has been created. + (list (shepherd-service + (requirement '(file-systems)) + (provision '(user-homes)) + (modules '((gnu build activation))) + (start (with-imported-modules (source-module-closure + '((gnu build activation))) + #~(lambda () + (activate-user-home + (list #$@(map user-account->gexp accounts))) + #f))) ;stop + (stop #~(const #f)) + (respawn? #f) + (documentation "Create user home directories.")))) + (define (shells-file shells) "Return a file-like object that builds a shell list for use as /etc/shells based on SHELLS. /etc/shells is used by xterm, polkit, and other programs." @@ -327,6 +359,8 @@ the /etc/skel directory for those." (extensions (list (service-extension activation-service-type account-activation) + (service-extension shepherd-root-service-type + account-shepherd-service) (service-extension etc-service-type etc-files))))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 1e680b85a2..8a35f7fbc5 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -31,6 +31,7 @@ #:use-module ((gnu build vm) #:select (qemu-command)) #:use-module (gnu packages base) + #:use-module (gnu packages bootloaders) #:use-module (gnu packages guile) #:use-module (gnu packages gawk) #:use-module (gnu packages bash) @@ -38,7 +39,6 @@ #:use-module (gnu packages qemu) #:use-module (gnu packages disk) #:use-module (gnu packages zile) - #:use-module (gnu packages grub) #:use-module (gnu packages linux) #:use-module (gnu packages package-management) #:use-module ((gnu packages make-bootstrap) |