diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/file-systems.scm | 60 | ||||
| -rw-r--r-- | gnu/system/install.scm | 106 | ||||
| -rw-r--r-- | gnu/system/os-config.tmpl | 31 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 44 |
4 files changed, 219 insertions, 22 deletions
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 7852a6ab26..48c4fc7e77 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -28,9 +28,16 @@ file-system-needed-for-boot? file-system-flags file-system-options + file-system-check? + file-system-create-mount-point? %fuse-control-file-system - %binary-format-file-system)) + %binary-format-file-system + %shared-memory-file-system + %pseudo-terminal-file-system + %devtmpfs-file-system + + %base-file-systems)) ;;; Commentary: ;;; @@ -54,7 +61,9 @@ (needed-for-boot? file-system-needed-for-boot? ; Boolean (default #f)) (check? file-system-check? ; Boolean - (default #t))) + (default #t)) + (create-mount-point? file-system-create-mount-point? ; Boolean + (default #f))) (define %fuse-control-file-system ;; Control file system for Linux' file systems in user-space (FUSE). @@ -72,4 +81,51 @@ (type "binfmt_misc") (check? #f))) +(define %devtmpfs-file-system + ;; /dev as a 'devtmpfs' file system, needed for udev. + (file-system + (device "none") + (mount-point "/dev") + (type "devtmpfs") + (check? #f) + + ;; Mount it from the initrd so /dev/pts & co. can then be mounted over it. + (needed-for-boot? #t))) + +(define %tty-gid + ;; ID of the 'tty' group. Allocate it statically to make it easy to refer + ;; to it from here and from the 'tty' group definitions. + 996) + +(define %pseudo-terminal-file-system + ;; The pseudo-terminal file system. It needs to be mounted so that + ;; statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) expects (and + ;; thus openpty(3) and its users, such as xterm.) + (file-system + (device "none") + (mount-point "/dev/pts") + (type "devpts") + (check? #f) + (needed-for-boot? #f) + (create-mount-point? #t) + (options (string-append "gid=" (number->string %tty-gid) ",mode=620")))) + +(define %shared-memory-file-system + ;; Shared memory. + (file-system + (device "tmpfs") + (mount-point "/dev/shm") + (type "tmpfs") + (check? #f) + (flags '(no-suid no-dev)) + (options "size=50%") ;TODO: make size configurable + (create-mount-point? #t))) + +(define %base-file-systems + ;; List of basic file systems to be mounted. Note that /proc and /sys are + ;; currently mounted by the initrd. + (list %devtmpfs-file-system + %pseudo-terminal-file-system + %shared-memory-file-system)) + ;;; file-systems.scm ends here diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 18fd587ead..567934e4c1 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -20,6 +20,7 @@ #:use-module (gnu) #:use-module (guix gexp) #:use-module (guix monads) + #:use-module ((guix store) #:select (%store-prefix)) #:use-module (gnu packages linux) #:use-module (gnu packages package-management) #:use-module (gnu packages disk) @@ -42,6 +43,99 @@ manual." "-f" (string-append #$guix "/share/info/guix.info") "-n" "System Installation"))) +(define %backing-directory + ;; Sub-directory used as the backing store for copy-on-write. + "/tmp/guix-inst") + +(define (make-cow-store target) + "Return a gexp that makes the store copy-on-write, using TARGET as the +backing store. This is useful when TARGET is on a hard disk, whereas the +current store is on a RAM disk." + (define (unionfs read-only read-write mount-point) + ;; Make MOUNT-POINT the union of READ-ONLY and READ-WRITE. + + ;; Note: in the command below, READ-WRITE appears before READ-ONLY so that + ;; it is considered a "higher-level branch", as per unionfs-fuse(8), + ;; thereby allowing files existing on READ-ONLY to be copied over to + ;; READ-WRITE. + #~(fork+exec-command + (list (string-append #$unionfs-fuse "/bin/unionfs") + "-o" + "cow,allow_other,use_ino,max_files=65536,nonempty" + (string-append #$read-write "=RW:" #$read-only "=RO") + #$mount-point))) + + (define (set-store-permissions directory) + ;; Set the right perms on DIRECTORY to use it as the store. + #~(begin + (chown #$directory 0 30000) ;use the fixed 'guixbuild' GID + (chmod #$directory #o1775))) + + #~(begin + (unless (file-exists? "/.ro-store") + (mkdir "/.ro-store") + (mount #$(%store-prefix) "/.ro-store" "none" + (logior MS_BIND MS_RDONLY))) + + (let ((rw-dir (string-append target #$%backing-directory))) + (mkdir-p rw-dir) + (mkdir-p "/.rw-store") + #$(set-store-permissions #~rw-dir) + #$(set-store-permissions "/.rw-store") + + ;; Mount the union, then atomically make it the store. + (and #$(unionfs "/.ro-store" #~rw-dir "/.rw-store") + (begin + (sleep 1) ;XXX: wait for unionfs to be ready + (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE) + (rmdir "/.rw-store")))))) + +(define (cow-store-service) + "Return a service that makes the store copy-on-write, such that writes go to +the user's target storage device rather than on the RAM disk." + ;; See <http://bugs.gnu.org/18061> for the initial report. + (with-monad %store-monad + (return (service + (requirement '(root-file-system user-processes)) + (provision '(cow-store)) + (documentation + "Make the store copy-on-write, with writes going to \ +the given target.") + (start #~(case-lambda + ((target) + #$(make-cow-store #~target) + target) + (else + ;; Do nothing, and mark the service as stopped. + #f))) + (stop #~(lambda (target) + ;; Delete the temporary directory, but leave everything + ;; mounted as there may still be processes using it + ;; since 'user-processes' doesn't depend on us. + (delete-file-recursively + (string-append target #$%backing-directory)))))))) + +(define (configuration-template-service) + "Return a dummy service whose purpose is to install an operating system +configuration template file in the installation system." + + (define local-template + "/etc/configuration-template.scm") + (define template + (search-path %load-path "gnu/system/os-config.tmpl")) + + (mlet %store-monad ((template (interned-file template))) + (return (service + (requirement '(root-file-system)) + (provision '(os-config-template)) + (documentation + "This dummy service installs an OS configuration template.") + (start #~(const #t)) + (stop #~(const #f)) + (activate + #~(unless (file-exists? #$local-template) + (copy-file #$template #$local-template))))))) + (define (installation-services) "Return the list services for the installation image." (let ((motd (text-file "motd" " @@ -71,6 +165,9 @@ You have been warned. Thanks for being so brave. #:auto-login "guest" #:login-program (log-to-info)) + ;; Documentation add-on. + (configuration-template-service) + ;; A bunch of 'root' ttys. (normal-tty "tty3") (normal-tty "tty4") @@ -88,6 +185,10 @@ You have been warned. Thanks for being so brave. ;; Start udev so that useful device nodes are available. (udev-service) + ;; Add the 'cow-store' service, which users have to start manually + ;; since it takes the installation directory as an argument. + (cow-store-service) + ;; Install Unicode support and a suitable font. (console-font-service "tty1") (console-font-service "tty2") @@ -117,10 +218,11 @@ Use Alt-F2 for documentation. (file-systems ;; Note: the disk image build code overrides this root file system with ;; the appropriate one. - (list (file-system + (cons (file-system (mount-point "/") (device "gnu-disk-image") - (type "ext4")))) + (type "ext4")) + %base-file-systems)) (users (list (user-account (name "guest") diff --git a/gnu/system/os-config.tmpl b/gnu/system/os-config.tmpl new file mode 100644 index 0000000000..ad58606f67 --- /dev/null +++ b/gnu/system/os-config.tmpl @@ -0,0 +1,31 @@ +;; This is an operating system configuration template. + +(use-modules (gnu)) + +(operating-system + (host-name "antelope") + (timezone "Europe/Paris") + (locale "en_US.UTF-8") + + ;; Assuming /dev/sdX is the target hard disk, and "root" is + ;; the label of the target root file system. + (bootloader (grub-configuration (device "/dev/sdX"))) + (file-systems (cons (file-system + (device "root") + (title 'label) + (mount-point "/") + (type "ext4")) + %base-file-systems)) + + ;; This is where user accounts are specified. The "root" + ;; account is implicit, and is initially created with the + ;; empty password. + (users (list (user-account + (name "alice") + (comment "Bob's sister") + (group "users") + + ;; Adding the account to the "wheel" group + ;; makes it a sudoer. + (supplementary-groups '("wheel")) + (home-directory "/home/alice"))))) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index ae6eac9a5b..5d638398d1 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -20,6 +20,8 @@ #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix monads) + #:use-module ((gnu system file-systems) + #:select (%tty-gid)) #:use-module ((gnu packages admin) #:select (shadow)) #:use-module (gnu packages bash) @@ -41,6 +43,7 @@ user-group-name user-group-password user-group-id + user-group-system? default-skeletons skeleton-directory @@ -73,28 +76,33 @@ user-group? (name user-group-name) (password user-group-password (default #f)) - (id user-group-id (default #f))) + (id user-group-id (default #f)) + (system? user-group-system? ; Boolean + (default #f))) (define %base-groups ;; Default set of groups. - (list (user-group (name "root") (id 0)) - (user-group (name "wheel")) ; root-like users - (user-group (name "users")) ; normal users - (user-group (name "nogroup")) ; for daemons etc. + (let-syntax ((system-group (syntax-rules () + ((_ args ...) + (user-group (system? #t) args ...))))) + (list (system-group (name "root") (id 0)) + (system-group (name "wheel")) ; root-like users + (system-group (name "users")) ; normal users + (system-group (name "nogroup")) ; for daemons etc. - ;; The following groups are conventionally used by things like udev to - ;; control access to hardware devices. - (user-group (name "tty")) - (user-group (name "dialout")) - (user-group (name "kmem")) - (user-group (name "video")) - (user-group (name "audio")) - (user-group (name "netdev")) ; used in avahi-dbus.conf - (user-group (name "lp")) - (user-group (name "disk")) - (user-group (name "floppy")) - (user-group (name "cdrom")) - (user-group (name "tape")))) + ;; The following groups are conventionally used by things like udev to + ;; control access to hardware devices. + (system-group (name "tty") (id %tty-gid)) + (system-group (name "dialout")) + (system-group (name "kmem")) + (system-group (name "video")) + (system-group (name "audio")) + (system-group (name "netdev")) ; used in avahi-dbus.conf + (system-group (name "lp")) + (system-group (name "disk")) + (system-group (name "floppy")) + (system-group (name "cdrom")) + (system-group (name "tape"))))) (define (default-skeletons) "Return the default skeleton files for /etc/skel. These files are copied by |