aboutsummaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/examples/bare-bones.tmpl2
-rw-r--r--gnu/system/examples/desktop.tmpl2
-rw-r--r--gnu/system/examples/lightweight-desktop.tmpl2
-rw-r--r--gnu/system/file-systems.scm94
-rw-r--r--gnu/system/grub.scm8
-rw-r--r--gnu/system/install.scm4
-rw-r--r--gnu/system/linux-container.scm21
-rw-r--r--gnu/system/mapped-devices.scm2
-rw-r--r--gnu/system/shadow.scm38
-rw-r--r--gnu/system/vm.scm2
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)
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-21 13:19:57 +0000