| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; |
| 4 | ;;; This file is part of GNU Guix. |
| 5 | ;;; |
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 7 | ;;; under the terms of the GNU General Public License as published by |
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 9 | ;;; your option) any later version. |
| 10 | ;;; |
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 14 | ;;; GNU General Public License for more details. |
| 15 | ;;; |
| 16 | ;;; You should have received a copy of the GNU General Public License |
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 18 | |
| 19 | (define-module (gnu system install) |
| 20 | #:use-module (gnu) |
| 21 | #:use-module (guix gexp) |
| 22 | #:use-module (guix store) |
| 23 | #:use-module (guix monads) |
| 24 | #:use-module ((guix store) #:select (%store-prefix)) |
| 25 | #:use-module (gnu packages admin) |
| 26 | #:use-module (gnu packages linux) |
| 27 | #:use-module (gnu packages cryptsetup) |
| 28 | #:use-module (gnu packages package-management) |
| 29 | #:use-module (gnu packages disk) |
| 30 | #:use-module (gnu packages grub) |
| 31 | #:use-module (gnu packages texinfo) |
| 32 | #:use-module (gnu packages compression) |
| 33 | #:export (installation-os)) |
| 34 | |
| 35 | ;;; Commentary: |
| 36 | ;;; |
| 37 | ;;; This module provides an 'operating-system' definition for use on images |
| 38 | ;;; for USB sticks etc., for the installation of the GNU system. |
| 39 | ;;; |
| 40 | ;;; Code: |
| 41 | |
| 42 | (define (log-to-info) |
| 43 | "Return a script that spawns the Info reader on the right section of the |
| 44 | manual." |
| 45 | (gexp->script "log-to-info" |
| 46 | #~(begin |
| 47 | ;; 'gunzip' is needed to decompress the doc. |
| 48 | (setenv "PATH" (string-append #$gzip "/bin")) |
| 49 | |
| 50 | (execl (string-append #$texinfo-4 "/bin/info") "info" |
| 51 | "-d" "/run/current-system/profile/share/info" |
| 52 | "-f" (string-append #$guix "/share/info/guix.info") |
| 53 | "-n" "System Installation")))) |
| 54 | |
| 55 | (define %backing-directory |
| 56 | ;; Sub-directory used as the backing store for copy-on-write. |
| 57 | "/tmp/guix-inst") |
| 58 | |
| 59 | (define (make-cow-store target) |
| 60 | "Return a gexp that makes the store copy-on-write, using TARGET as the |
| 61 | backing store. This is useful when TARGET is on a hard disk, whereas the |
| 62 | current store is on a RAM disk." |
| 63 | (define (unionfs read-only read-write mount-point) |
| 64 | ;; Make MOUNT-POINT the union of READ-ONLY and READ-WRITE. |
| 65 | |
| 66 | ;; Note: in the command below, READ-WRITE appears before READ-ONLY so that |
| 67 | ;; it is considered a "higher-level branch", as per unionfs-fuse(8), |
| 68 | ;; thereby allowing files existing on READ-ONLY to be copied over to |
| 69 | ;; READ-WRITE. |
| 70 | #~(fork+exec-command |
| 71 | (list (string-append #$unionfs-fuse "/bin/unionfs") |
| 72 | "-o" |
| 73 | "cow,allow_other,use_ino,max_files=65536,nonempty" |
| 74 | (string-append #$read-write "=RW:" #$read-only "=RO") |
| 75 | #$mount-point))) |
| 76 | |
| 77 | (define (set-store-permissions directory) |
| 78 | ;; Set the right perms on DIRECTORY to use it as the store. |
| 79 | #~(begin |
| 80 | (chown #$directory 0 30000) ;use the fixed 'guixbuild' GID |
| 81 | (chmod #$directory #o1775))) |
| 82 | |
| 83 | #~(begin |
| 84 | (unless (file-exists? "/.ro-store") |
| 85 | (mkdir "/.ro-store") |
| 86 | (mount #$(%store-prefix) "/.ro-store" "none" |
| 87 | (logior MS_BIND MS_RDONLY))) |
| 88 | |
| 89 | (let ((rw-dir (string-append target #$%backing-directory))) |
| 90 | (mkdir-p rw-dir) |
| 91 | (mkdir-p "/.rw-store") |
| 92 | #$(set-store-permissions #~rw-dir) |
| 93 | #$(set-store-permissions "/.rw-store") |
| 94 | |
| 95 | ;; Mount the union, then atomically make it the store. |
| 96 | (and #$(unionfs "/.ro-store" #~rw-dir "/.rw-store") |
| 97 | (begin |
| 98 | (sleep 1) ;XXX: wait for unionfs to be ready |
| 99 | (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE) |
| 100 | (rmdir "/.rw-store")))))) |
| 101 | |
| 102 | (define (cow-store-service) |
| 103 | "Return a service that makes the store copy-on-write, such that writes go to |
| 104 | the user's target storage device rather than on the RAM disk." |
| 105 | ;; See <http://bugs.gnu.org/18061> for the initial report. |
| 106 | (with-monad %store-monad |
| 107 | (return (service |
| 108 | (requirement '(root-file-system user-processes)) |
| 109 | (provision '(cow-store)) |
| 110 | (documentation |
| 111 | "Make the store copy-on-write, with writes going to \ |
| 112 | the given target.") |
| 113 | |
| 114 | ;; This is meant to be explicitly started by the user. |
| 115 | (auto-start? #f) |
| 116 | |
| 117 | (start #~(case-lambda |
| 118 | ((target) |
| 119 | #$(make-cow-store #~target) |
| 120 | target) |
| 121 | (else |
| 122 | ;; Do nothing, and mark the service as stopped. |
| 123 | #f))) |
| 124 | (stop #~(lambda (target) |
| 125 | ;; Delete the temporary directory, but leave everything |
| 126 | ;; mounted as there may still be processes using it |
| 127 | ;; since 'user-processes' doesn't depend on us. The |
| 128 | ;; 'user-unmount' service will unmount TARGET |
| 129 | ;; eventually. |
| 130 | (delete-file-recursively |
| 131 | (string-append target #$%backing-directory)))))))) |
| 132 | |
| 133 | (define (configuration-template-service) |
| 134 | "Return a dummy service whose purpose is to install an operating system |
| 135 | configuration template file in the installation system." |
| 136 | |
| 137 | (define local-template |
| 138 | "/etc/configuration-template.scm") |
| 139 | (define template |
| 140 | (search-path %load-path "gnu/system/os-config.tmpl")) |
| 141 | |
| 142 | (mlet %store-monad ((template (interned-file template))) |
| 143 | (return (service |
| 144 | (requirement '(root-file-system)) |
| 145 | (provision '(os-config-template)) |
| 146 | (documentation |
| 147 | "This dummy service installs an OS configuration template.") |
| 148 | (start #~(const #t)) |
| 149 | (stop #~(const #f)) |
| 150 | (activate |
| 151 | #~(unless (file-exists? #$local-template) |
| 152 | (copy-file #$template #$local-template))))))) |
| 153 | |
| 154 | (define %nscd-minimal-caches |
| 155 | ;; Minimal in-memory caching policy for nscd. |
| 156 | (list (nscd-cache (database 'hosts) |
| 157 | (positive-time-to-live (* 3600 12)) |
| 158 | (negative-time-to-live 20) |
| 159 | (persistent? #f) |
| 160 | (max-database-size (* 5 (expt 2 20)))))) ;5 MiB |
| 161 | |
| 162 | (define (installation-services) |
| 163 | "Return the list services for the installation image." |
| 164 | (let ((motd (text-file "motd" " |
| 165 | Welcome to the installation of the Guix System Distribution! |
| 166 | |
| 167 | There is NO WARRANTY, to the extent permitted by law. In particular, you may |
| 168 | LOSE ALL YOUR DATA as a side effect of the installation process. Furthermore, |
| 169 | it is alpha software, so it may BREAK IN UNEXPECTED WAYS. |
| 170 | |
| 171 | You have been warned. Thanks for being so brave. |
| 172 | "))) |
| 173 | (define (normal-tty tty) |
| 174 | (mingetty-service tty |
| 175 | #:motd motd |
| 176 | #:auto-login "root" |
| 177 | #:login-pause? #t)) |
| 178 | |
| 179 | (list (mingetty-service "tty1" |
| 180 | #:motd motd |
| 181 | #:auto-login "root") |
| 182 | |
| 183 | ;; Documentation. The manual is in UTF-8, but |
| 184 | ;; 'console-font-service' sets up Unicode support and loads a font |
| 185 | ;; with all the useful glyphs like em dash and quotation marks. |
| 186 | (mingetty-service "tty2" |
| 187 | #:motd motd |
| 188 | #:auto-login "guest" |
| 189 | #:login-program (log-to-info)) |
| 190 | |
| 191 | ;; Documentation add-on. |
| 192 | (configuration-template-service) |
| 193 | |
| 194 | ;; A bunch of 'root' ttys. |
| 195 | (normal-tty "tty3") |
| 196 | (normal-tty "tty4") |
| 197 | (normal-tty "tty5") |
| 198 | (normal-tty "tty6") |
| 199 | |
| 200 | ;; The usual services. |
| 201 | (syslog-service) |
| 202 | |
| 203 | ;; The build daemon. Register the hydra.gnu.org key as trusted. |
| 204 | ;; This allows the installation process to use substitutes by |
| 205 | ;; default. |
| 206 | (guix-service #:authorize-hydra-key? #t) |
| 207 | |
| 208 | ;; Start udev so that useful device nodes are available. |
| 209 | (udev-service) |
| 210 | |
| 211 | ;; Add the 'cow-store' service, which users have to start manually |
| 212 | ;; since it takes the installation directory as an argument. |
| 213 | (cow-store-service) |
| 214 | |
| 215 | ;; Install Unicode support and a suitable font. |
| 216 | (console-font-service "tty1") |
| 217 | (console-font-service "tty2") |
| 218 | (console-font-service "tty3") |
| 219 | (console-font-service "tty4") |
| 220 | (console-font-service "tty5") |
| 221 | (console-font-service "tty6") |
| 222 | |
| 223 | ;; Since this is running on a USB stick with a unionfs as the root |
| 224 | ;; file system, use an appropriate cache configuration. |
| 225 | (nscd-service (nscd-configuration |
| 226 | (caches %nscd-minimal-caches)))))) |
| 227 | |
| 228 | (define %issue |
| 229 | ;; Greeting. |
| 230 | " |
| 231 | This is an installation image of the GNU system. Welcome. |
| 232 | |
| 233 | Use Alt-F2 for documentation. |
| 234 | ") |
| 235 | |
| 236 | (define installation-os |
| 237 | ;; The operating system used on installation images for USB sticks etc. |
| 238 | (operating-system |
| 239 | (host-name "gnu") |
| 240 | (timezone "Europe/Paris") |
| 241 | (locale "en_US.utf8") |
| 242 | (bootloader (grub-configuration |
| 243 | (device "/dev/sda"))) |
| 244 | (file-systems |
| 245 | ;; Note: the disk image build code overrides this root file system with |
| 246 | ;; the appropriate one. |
| 247 | (cons (file-system |
| 248 | (mount-point "/") |
| 249 | (device "gnu-disk-image") |
| 250 | (type "ext4")) |
| 251 | %base-file-systems)) |
| 252 | |
| 253 | (users (list (user-account |
| 254 | (name "guest") |
| 255 | (group "users") |
| 256 | (supplementary-groups '("wheel")) ; allow use of sudo |
| 257 | (password "") |
| 258 | (comment "Guest of GNU") |
| 259 | (home-directory "/home/guest")))) |
| 260 | |
| 261 | (issue %issue) |
| 262 | |
| 263 | (services (installation-services)) |
| 264 | |
| 265 | ;; We don't need setuid programs so pass the empty list so we don't pull |
| 266 | ;; additional programs here. |
| 267 | (setuid-programs '()) |
| 268 | |
| 269 | (pam-services |
| 270 | ;; Explicitly allow for empty passwords. |
| 271 | (base-pam-services #:allow-empty-passwords? #t)) |
| 272 | |
| 273 | (packages (cons* texinfo-4 ;for the standalone Info reader |
| 274 | parted ddrescue |
| 275 | grub ;mostly so xrefs to its manual work |
| 276 | cryptsetup |
| 277 | wireless-tools iw wpa-supplicant-light |
| 278 | ;; XXX: We used to have GNU fdisk here, but as of version |
| 279 | ;; 2.0.0a, that pulls Guile 1.8, which takes unreasonable |
| 280 | ;; space; furthermore util-linux's fdisk is already |
| 281 | ;; available here, so we keep that. |
| 282 | %base-packages)))) |
| 283 | |
| 284 | ;; Return it here so 'guix system' can consume it directly. |
| 285 | installation-os |
| 286 | |
| 287 | ;;; install.scm ends here |