[jackhill/guix/guix.git] / gnu / installer / final.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020 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 installer final)
  #:use-module (gnu installer newt page)
  #:use-module (gnu installer steps)
  #:use-module (gnu installer utils)
  #:use-module (gnu installer user)
  #:use-module (gnu services herd)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (gnu build accounts)
  #:use-module (gnu build install)
  #:use-module (gnu build linux-container)
  #:use-module ((gnu system shadow) #:prefix sys:)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 rdelim)
  #:export (install-system))

(define %seed
  (seed->random-state
   (logxor (getpid) (car (gettimeofday)))))

(define (integer->alphanumeric-char n)
  "Map N, an integer in the [0..62] range, to an alphanumeric character."
  (cond ((< n 10)
         (integer->char (+ (char->integer #\0) n)))
        ((< n 36)
         (integer->char (+ (char->integer #\A) (- n 10))))
        ((< n 62)
         (integer->char (+ (char->integer #\a) (- n 36))))
        (else
         (error "integer out of bounds" n))))

(define (random-string len)
  "Compute a random string of size LEN where each character is alphanumeric."
  (let loop ((chars '())
             (len len))
    (if (zero? len)
        (list->string chars)
        (let ((n (random 62 %seed)))
          (loop (cons (integer->alphanumeric-char n) chars)
                (- len 1))))))

(define (create-user-database users root)
  "Create /etc/passwd, /etc/shadow, and /etc/group under ROOT for the given
USERS."
  (define etc
    (string-append root "/etc"))

  (define (salt)
    ;; "$6" gives us a SHA512 password hash; the random string must be taken
    ;; from the './0-9A-Za-z' alphabet (info "(libc) Passphrase Storage").
    (string-append "$6$" (random-string 10)))

  (define users*
    (map (lambda (user)
           (define root?
             (string=? "root" (user-name user)))

           (sys:user-account (name (user-name user))
                             (comment (user-real-name user))
                             (group "users")
                             (uid (if root? 0 #f))
                             (home-directory
                              (user-home-directory user))
                             (password (crypt (user-password user)
                                              (salt)))

                             ;; We need a string here, not a file-like, hence
                             ;; this choice.
                             (shell
                              "/run/current-system/profile/bin/bash")))
         users))

  (define-values (group password shadow)
    (user+group-databases users* sys:%base-groups
                          #:current-passwd '()
                          #:current-groups '()
                          #:current-shadow '()))

  (mkdir-p etc)
  (write-group group (string-append etc "/group"))
  (write-passwd password (string-append etc "/passwd"))
  (write-shadow shadow (string-append etc "/shadow")))

(define* (kill-cow-users cow-path #:key (spare '("udevd")))
  "Kill all processes that have references to the given COW-PATH in their
'maps' file.  The process whose names are in SPARE list are spared."
  (define %not-nul
    (char-set-complement (char-set #\nul)))

  (let ((pids
         (filter-map (lambda (pid)
                       (false-if-exception
                        (call-with-input-file
                            (string-append "/proc/" pid "/maps")
                          (lambda (port)
                            (and (string-contains (get-string-all port)
                                                  cow-path)
                                 (string->number pid))))))
                     (scandir "/proc" string->number))))
    (for-each (lambda (pid)
                ;; cmdline does not always exist.
                (false-if-exception
                 (call-with-input-file
                     (string-append "/proc/" (number->string pid) "/cmdline")
                   (lambda (port)
                     (match (string-tokenize (read-string port) %not-nul)
                       ((argv0 _ ...)
                        (unless (member (basename argv0) spare)
                          (syslog "Killing process ~a (~a)~%" pid argv0)
                          (kill pid SIGKILL)))
                       (_ #f))))))
              pids)))

(define (call-with-mnt-container thunk)
  "This is a variant of call-with-container. Run THUNK in a new container
process, within a separate MNT namespace. The container is not jailed so that
it can interact with the rest of the system."
  (let ((pid (run-container "/" '() '(mnt) 1 thunk)))
    ;; Catch SIGINT and kill the container process.
    (sigaction SIGINT
      (lambda (signum)
        (false-if-exception
         (kill pid SIGKILL))))

    (match (waitpid pid)
      ((_ . status) status))))

(define* (install-system locale #:key (users '()))
  "Create /etc/shadow and /etc/passwd on the installation target for USERS.
Start COW-STORE service on target directory and launch guix install command in
a subshell.  LOCALE must be the locale name under which that command will run,
or #f.  Return #t on success and #f on failure."
  (define backing-directory
    ;; Sub-directory used as the backing store for copy-on-write.
    "/tmp/guix-inst")

  (define (assert-exit x)
    (primitive-exit (if x 0 1)))

  (let* ((options         (catch 'system-error
                            (lambda ()
                              ;; If this file exists, it can provide
                              ;; additional command-line options.
                              (call-with-input-file
                                  "/tmp/installer-system-init-options"
                                read))
                            (const '())))
         (install-command (append (list "guix" "system" "init"
                                        "--fallback")
                                  options
                                  (list (%installer-configuration-file)
                                        (%installer-target-dir))))
         (database-dir    "/var/guix/db")
         (database-file   (string-append database-dir "/db.sqlite"))
         (saved-database  (string-append database-dir "/db.save"))
         (ret             #f))
    (mkdir-p (%installer-target-dir))

    ;; We want to initialize user passwords but we don't want to store them in
    ;; the config file since the password hashes would end up world-readable
    ;; in the store.  Thus, create /etc/shadow & co. here such that, on the
    ;; first boot, the activation snippet that creates accounts will reuse the
    ;; passwords that we've put in there.
    (create-user-database users (%installer-target-dir))

    ;; When the store overlay is mounted, other processes such as kmscon, udev
    ;; and guix-daemon may open files from the store, preventing the
    ;; underlying install support from being umounted. See:
    ;; https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html.
    ;;
    ;; To avoid this situation, mount the store overlay inside a container,
    ;; and run the installation from within that container.
    (zero?
     (call-with-mnt-container
       (lambda ()
         (dynamic-wind
           (lambda ()
             ;; Save the database, so that it can be restored once the
             ;; cow-store is umounted.
             (copy-file database-file saved-database)
             (mount-cow-store (%installer-target-dir) backing-directory))
           (lambda ()
             ;; We need to drag the guix-daemon to the container MNT
             ;; namespace, so that it can operate on the cow-store.
             (stop-service 'guix-daemon)
             (start-service 'guix-daemon (list (number->string (getpid))))

             (setvbuf (current-output-port) 'none)
             (setvbuf (current-error-port) 'none)

             ;; If there are any connected clients, assume that we are running
             ;; installation tests. In that case, dump the standard and error
             ;; outputs to syslog.
             (set! ret
                   (if (not (null? (current-clients)))
                       (with-output-to-file "/dev/console"
                         (lambda ()
                           (with-error-to-file "/dev/console"
                             (lambda ()
                               (run-command install-command
                                            #:locale locale)))))
                       (run-command install-command #:locale locale))))
           (lambda ()
             ;; Restart guix-daemon so that it does no keep the MNT namespace
             ;; alive.
             (restart-service 'guix-daemon)
             (copy-file saved-database database-file)

             ;; Finally umount the cow-store and exit the container.
             (unmount-cow-store (%installer-target-dir) backing-directory)
             (assert-exit ret))))))))
Commit	Line	Data
dc5f3275	1	;;; GNU Guix --- Functional package management for GNU
1d020520	2	;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
8a4b11c6	3	;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
dc5f3275 MO	4	;;;
	5	;;; This file is part of GNU Guix.
	6	;;;
	7	;;; GNU Guix is free software; you can redistribute it and/or modify it
	8	;;; under the terms of the GNU General Public License as published by
	9	;;; the Free Software Foundation; either version 3 of the License, or (at
	10	;;; your option) any later version.
	11	;;;
	12	;;; GNU Guix is distributed in the hope that it will be useful, but
	13	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;;; GNU General Public License for more details.
	16	;;;
	17	;;; You should have received a copy of the GNU General Public License
	18	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	19
	20	(define-module (gnu installer final)
	21	#:use-module (gnu installer newt page)
	22	#:use-module (gnu installer steps)
	23	#:use-module (gnu installer utils)
898677ed	24	#:use-module (gnu installer user)
dc5f3275	25	#:use-module (gnu services herd)
1d020520	26	#:use-module (guix build syscalls)
dc5f3275	27	#:use-module (guix build utils)
898677ed	28	#:use-module (gnu build accounts)
8ce6f4dc MO	29	#:use-module (gnu build install)
8ce6f4dc MO	30	#:use-module (gnu build linux-container)
898677ed LC	31	#:use-module ((gnu system shadow) #:prefix sys:)
898677ed LC	32	#:use-module (rnrs io ports)
64704be4 MO	33	#:use-module (srfi srfi-1)
	34	#:use-module (ice-9 ftw)
	35	#:use-module (ice-9 popen)
	36	#:use-module (ice-9 match)
	37	#:use-module (ice-9 format)
	38	#:use-module (ice-9 rdelim)
dc5f3275 MO	39	#:export (install-system))
dc5f3275 MO	40
898677ed LC	41	(define %seed
	42	(seed->random-state
	43	(logxor (getpid) (car (gettimeofday)))))
	44
	45	(define (integer->alphanumeric-char n)
	46	"Map N, an integer in the [0..62] range, to an alphanumeric character."
	47	(cond ((< n 10)
	48	(integer->char (+ (char->integer #\0) n)))
	49	((< n 36)
	50	(integer->char (+ (char->integer #\A) (- n 10))))
	51	((< n 62)
	52	(integer->char (+ (char->integer #\a) (- n 36))))
	53	(else
	54	(error "integer out of bounds" n))))
	55
	56	(define (random-string len)
	57	"Compute a random string of size LEN where each character is alphanumeric."
	58	(let loop ((chars '())
	59	(len len))
	60	(if (zero? len)
	61	(list->string chars)
	62	(let ((n (random 62 %seed)))
	63	(loop (cons (integer->alphanumeric-char n) chars)
	64	(- len 1))))))
	65
	66	(define (create-user-database users root)
	67	"Create /etc/passwd, /etc/shadow, and /etc/group under ROOT for the given
	68	USERS."
	69	(define etc
	70	(string-append root "/etc"))
	71
	72	(define (salt)
	73	;; "$6" gives us a SHA512 password hash; the random string must be taken
	74	;; from the './0-9A-Za-z' alphabet (info "(libc) Passphrase Storage").
	75	(string-append "$6$" (random-string 10)))
	76
	77	(define users*
	78	(map (lambda (user)
91a7c499 LC	79	(define root?
	80	(string=? "root" (user-name user)))
	81
898677ed	82	(sys:user-account (name (user-name user))
0e8e963d	83	(comment (user-real-name user))
898677ed	84	(group "users")
91a7c499	85	(uid (if root? 0 #f))
898677ed LC	86	(home-directory
	87	(user-home-directory user))
	88	(password (crypt (user-password user)
	89	(salt)))
	90
	91	;; We need a string here, not a file-like, hence
	92	;; this choice.
	93	(shell
	94	"/run/current-system/profile/bin/bash")))
	95	users))
	96
	97	(define-values (group password shadow)
	98	(user+group-databases users* sys:%base-groups
	99	#:current-passwd '()
	100	#:current-groups '()
	101	#:current-shadow '()))
	102
	103	(mkdir-p etc)
	104	(write-group group (string-append etc "/group"))
	105	(write-passwd password (string-append etc "/passwd"))
	106	(write-shadow shadow (string-append etc "/shadow")))
	107
64704be4 MO	108	(define* (kill-cow-users cow-path #:key (spare '("udevd")))
	109	"Kill all processes that have references to the given COW-PATH in their
	110	'maps' file. The process whose names are in SPARE list are spared."
	111	(define %not-nul
	112	(char-set-complement (char-set #\nul)))
	113
	114	(let ((pids
	115	(filter-map (lambda (pid)
f9b6f75d MO	116	(false-if-exception
	117	(call-with-input-file
	118	(string-append "/proc/" pid "/maps")
	119	(lambda (port)
	120	(and (string-contains (get-string-all port)
	121	cow-path)
	122	(string->number pid))))))
64704be4 MO	123	(scandir "/proc" string->number))))
	124	(for-each (lambda (pid)
	125	;; cmdline does not always exist.
	126	(false-if-exception
	127	(call-with-input-file
	128	(string-append "/proc/" (number->string pid) "/cmdline")
	129	(lambda (port)
	130	(match (string-tokenize (read-string port) %not-nul)
	131	((argv0 _ ...)
ce16b07d	132	(unless (member (basename argv0) spare)
7730f41a	133	(syslog "Killing process ~a (~a)~%" pid argv0)
64704be4 MO	134	(kill pid SIGKILL)))
	135	(_ #f))))))
	136	pids)))
	137
cafbc5f3 MO	138	(define (call-with-mnt-container thunk)
	139	"This is a variant of call-with-container. Run THUNK in a new container
	140	process, within a separate MNT namespace. The container is not jailed so that
	141	it can interact with the rest of the system."
	142	(let ((pid (run-container "/" '() '(mnt) 1 thunk)))
	143	;; Catch SIGINT and kill the container process.
	144	(sigaction SIGINT
	145	(lambda (signum)
	146	(false-if-exception
	147	(kill pid SIGKILL))))
	148
	149	(match (waitpid pid)
	150	((_ . status) status))))
	151
898677ed LC	152	(define* (install-system locale #:key (users '()))
	153	"Create /etc/shadow and /etc/passwd on the installation target for USERS.
	154	Start COW-STORE service on target directory and launch guix install command in
	155	a subshell. LOCALE must be the locale name under which that command will run,
9529f785	156	or #f. Return #t on success and #f on failure."
8ce6f4dc MO	157	(define backing-directory
	158	;; Sub-directory used as the backing store for copy-on-write.
	159	"/tmp/guix-inst")
	160
	161	(define (assert-exit x)
	162	(primitive-exit (if x 0 1)))
	163
e458726a LC	164	(let* ((options (catch 'system-error
	165	(lambda ()
	166	;; If this file exists, it can provide
	167	;; additional command-line options.
	168	(call-with-input-file
	169	"/tmp/installer-system-init-options"
	170	read))
	171	(const '())))
	172	(install-command (append (list "guix" "system" "init"
	173	"--fallback")
	174	options
	175	(list (%installer-configuration-file)
8ce6f4dc MO	176	(%installer-target-dir))))
	177	(database-dir "/var/guix/db")
	178	(database-file (string-append database-dir "/db.sqlite"))
	179	(saved-database (string-append database-dir "/db.save"))
	180	(ret #f))
dc5f3275	181	(mkdir-p (%installer-target-dir))
898677ed LC	182
	183	;; We want to initialize user passwords but we don't want to store them in
	184	;; the config file since the password hashes would end up world-readable
	185	;; in the store. Thus, create /etc/shadow & co. here such that, on the
	186	;; first boot, the activation snippet that creates accounts will reuse the
	187	;; passwords that we've put in there.
	188	(create-user-database users (%installer-target-dir))
	189
8ce6f4dc MO	190	;; When the store overlay is mounted, other processes such as kmscon, udev
	191	;; and guix-daemon may open files from the store, preventing the
	192	;; underlying install support from being umounted. See:
	193	;; https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html.
	194	;;
	195	;; To avoid this situation, mount the store overlay inside a container,
	196	;; and run the installation from within that container.
	197	(zero?
cafbc5f3	198	(call-with-mnt-container
8ce6f4dc MO	199	(lambda ()
	200	(dynamic-wind
	201	(lambda ()
	202	;; Save the database, so that it can be restored once the
	203	;; cow-store is umounted.
	204	(copy-file database-file saved-database)
	205	(mount-cow-store (%installer-target-dir) backing-directory))
	206	(lambda ()
	207	;; We need to drag the guix-daemon to the container MNT
	208	;; namespace, so that it can operate on the cow-store.
	209	(stop-service 'guix-daemon)
	210	(start-service 'guix-daemon (list (number->string (getpid))))
	211
	212	(setvbuf (current-output-port) 'none)
	213	(setvbuf (current-error-port) 'none)
	214
	215	;; If there are any connected clients, assume that we are running
	216	;; installation tests. In that case, dump the standard and error
	217	;; outputs to syslog.
	218	(set! ret
	219	(if (not (null? (current-clients)))
	220	(with-output-to-file "/dev/console"
	221	(lambda ()
	222	(with-error-to-file "/dev/console"
	223	(lambda ()
	224	(run-command install-command
	225	#:locale locale)))))
	226	(run-command install-command #:locale locale))))
	227	(lambda ()
	228	;; Restart guix-daemon so that it does no keep the MNT namespace
	229	;; alive.
	230	(restart-service 'guix-daemon)
	231	(copy-file saved-database database-file)
	232
	233	;; Finally umount the cow-store and exit the container.
	234	(unmount-cow-store (%installer-target-dir) backing-directory)
cafbc5f3	235	(assert-exit ret))))))))