;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
-;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;; 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.
;;;
#: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
(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."
- (let ((install-command
- (format #f "guix system init ~a ~a"
- (%installer-configuration-file)
- (%installer-target-dir))))
+ (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
;; passwords that we've put in there.
(create-user-database users (%installer-target-dir))
- (start-service 'cow-store (list (%installer-target-dir)))
- (run-shell-command install-command #:locale locale)))
+ ;; 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))))))))
HCoop / jackhill / guix / guix.git / blobdiff