[jackhill/guix/guix.git] / gnu / system / install.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu system install)
  #:use-module (gnu)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module ((guix store) #:select (%store-prefix))
  #:use-module (gnu packages admin)
  #: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)
  #:export (installation-os))

;;; Commentary:
;;;
;;; This module provides an 'operating-system' definition for use on images
;;; for USB sticks etc., for the installation of the GNU system.
;;;
;;; Code:

(define (log-to-info)
  "Return a script that spawns the Info reader on the right section of the
manual."
  (gexp->script "log-to-info"
                #~(execl (string-append #$texinfo-4 "/bin/info") "info"
                         "-d" "/run/current-system/profile/share/info"
                         "-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.")

             ;; This is meant to be explicitly started by the user.
             (auto-start? #f)

             (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.  The
                       ;; 'user-unmount' service will unmount TARGET
                       ;; eventually.
                       (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" "
Welcome to the installation of the GNU operating system!

There is NO WARRANTY, to the extent permitted by law.  In particular, you may
LOSE ALL YOUR DATA as a side effect of the installation process.  Furthermore,
it is alpha software, so it may BREAK IN UNEXPECTED WAYS.

You have been warned.  Thanks for being so brave.
")))
    (define (normal-tty tty)
      (mingetty-service tty
                        #:motd motd
                        #:auto-login "root"
                        #:login-pause? #t))

    (list (mingetty-service "tty1"
                            #:motd motd
                            #:auto-login "root")

          ;; Documentation.  The manual is in UTF-8, but
          ;; 'console-font-service' sets up Unicode support and loads a font
          ;; with all the useful glyphs like em dash and quotation marks.
          (mingetty-service "tty2"
                            #:motd motd
                            #: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")
          (normal-tty "tty5")
          (normal-tty "tty6")

          ;; The usual services.
          (syslog-service)

          ;; The build daemon.  Register the hydra.gnu.org key as trusted.
          ;; This allows the installation process to use substitutes by
          ;; default.
          (guix-service #:authorize-hydra-key? #t)

          ;; 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")
          (console-font-service "tty3")
          (console-font-service "tty4")
          (console-font-service "tty5")
          (console-font-service "tty6")

          (nscd-service))))

(define %issue
  ;; Greeting.
  "
This is an installation image of the GNU system.  Welcome.

Use Alt-F2 for documentation.
")

(define installation-os
  ;; The operating system used on installation images for USB sticks etc.
  (operating-system
    (host-name "gnu")
    (timezone "Europe/Paris")
    (locale "en_US.utf8")
    (bootloader (grub-configuration
                 (device "/dev/sda")))
    (file-systems
     ;; Note: the disk image build code overrides this root file system with
     ;; the appropriate one.
     (cons (file-system
             (mount-point "/")
             (device "gnu-disk-image")
             (type "ext4"))
           %base-file-systems))

    (users (list (user-account
                  (name "guest")
                  (group "users")
                  (supplementary-groups '("wheel"))  ; allow use of sudo
                  (password "")
                  (comment "Guest of GNU")
                  (home-directory "/home/guest"))))

    (issue %issue)

    (services (installation-services))

    ;; We don't need setuid programs so pass the empty list so we don't pull
    ;; additional programs here.
    (setuid-programs '())

    (pam-services
     ;; Explicitly allow for empty passwords.
     (base-pam-services #:allow-empty-passwords? #t))

    (packages (cons* texinfo-4                 ;for the standalone Info reader
                     parted ddrescue
                     grub                  ;mostly so xrefs to its manual work
                     cryptsetup
                     wireless-tools wpa-supplicant
                     ;; XXX: We used to have GNU fdisk here, but as of version
                     ;; 2.0.0a, that pulls Guile 1.8, which takes unreasonable
                     ;; space; furthermore util-linux's fdisk is already
                     ;; available here, so we keep that.
                     %base-packages))))

;; Return it here so 'guix system' can consume it directly.
installation-os

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