From cf98d342b0899be3b72438d2dd5a2350f0f78f33 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 3 Feb 2017 09:50:09 +0100 Subject: activation: Set the right owner for home directories. This fixes a regression introduced in ae763b5b0b7d5e7316a3d0efe991fe8ab2261031 whereby home directories and skeletons would be root-owned. * gnu/build/activation.scm (copy-account-skeletons): Make 'directory' a keyword parameter. Add #:uid and #:gid and honor them. [set-owner]: New procedure. (activate-user-home): Add call to 'getpw' and 'chown'. Pass UID and GID to 'copy-account-skeletons'. * gnu/tests/base.scm (run-basic-test)["skeletons in home directories"]: Test file ownership under HOME. --- gnu/build/activation.scm | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index cff176e82a..e58304e83b 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -85,16 +85,27 @@ (chmod file (logior #o600 (stat:perms stat))))) (define* (copy-account-skeletons home - #:optional (directory %skeleton-directory)) - "Copy the account skeletons from DIRECTORY to HOME." + #:key + (directory %skeleton-directory) + uid gid) + "Copy the account skeletons from DIRECTORY to HOME. When UID is an integer, +make it the owner of all the files created; likewise for GID." + (define (set-owner file) + (when (or uid gid) + (chown file (or uid -1) (or gid -1)))) + (let ((files (scandir directory (negate dot-or-dot-dot?) string Date: Sat, 4 Feb 2017 18:10:14 +0100 Subject: linux-container: Do not rely on 'isatty?'. This avoids problems where 'isatty?' return #t but 'ttyname' fails with ENOTTY or such. * gnu/build/linux-container.scm (mount-file-systems): Remove call of 'isatty?'. Directly call 'ttyname' and catch 'system-error'. --- gnu/build/linux-container.scm | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) (limited to 'gnu/build') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index b71d6a5f88..cd71239527 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -128,13 +128,19 @@ for the process." "/dev/fuse")) ;; Setup the container's /dev/console by bind mounting the pseudo-terminal - ;; associated with standard input. - (let ((in (current-input-port)) - (console (scope "/dev/console"))) - (when (isatty? in) + ;; associated with standard input when there is one. + (let* ((in (current-input-port)) + (tty (catch 'system-error + (lambda () + ;; This call throws if IN does not correspond to a tty. + ;; This is more reliable than 'isatty?'. + (ttyname in)) + (const #f))) + (console (scope "/dev/console"))) + (when tty (touch console) (chmod console #o600) - (bind-mount (ttyname in) console))) + (bind-mount tty console))) ;; Setup standard input/output/error. (symlink "/proc/self/fd" (scope "/dev/fd")) -- cgit v1.2.3 From 36c4917c910f434524aae32725582d5bc51a44e0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 4 Feb 2017 18:14:12 +0100 Subject: linux-container: Add comment on exception handling. * gnu/build/linux-container.scm (run-container): Add note about writing the exceptions. --- gnu/build/linux-container.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'gnu/build') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index cd71239527..dd56a79232 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -235,6 +235,8 @@ host user identifiers to map into the user namespace." namespaces))) (lambda args ;; Forward the exception to the parent process. + ;; FIXME: SRFI-35 conditions and non-trivial objects + ;; cannot be 'read' so they shouldn't be written as is. (write args child) (primitive-exit 3)))) ;; TODO: Manage capabilities. -- cgit v1.2.3 From c90db25f4cf1f98f3f4f3af38d175a14ffb8c32a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Feb 2017 23:45:00 +0100 Subject: linux-container: Add 'container-excursion*'. * gnu/build/linux-container.scm (container-excursion*): New procedure. * tests/containers.scm ("container-excursion*") ("container-excursion*, same namespaces"): New tests. --- gnu/build/linux-container.scm | 22 +++++++++++++++++++++- tests/containers.scm | 27 +++++++++++++++++++++++++++ 2 files changed, 48 insertions(+), 1 deletion(-) (limited to 'gnu/build') diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index dd56a79232..95bfd92dde 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson +;;; Copyright © 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,7 +33,8 @@ %namespaces run-container call-with-container - container-excursion)) + container-excursion + container-excursion*)) (define (user-namespace-supported?) "Return #t if user namespaces are supported on this system." @@ -326,3 +328,21 @@ return the exit status." (match (waitpid pid) ((_ . status) (status:exit-val status)))))) + +(define (container-excursion* pid thunk) + "Like 'container-excursion', but return the return value of THUNK." + (match (pipe) + ((in . out) + (match (container-excursion pid + (lambda () + (close-port in) + (write (thunk) out))) + (0 + (close-port out) + (let ((result (read in))) + (close-port in) + result)) + (_ ;maybe PID died already + (close-port out) + (close-port in) + #f))))) diff --git a/tests/containers.scm b/tests/containers.scm index 745b56b710..0b3a4be12b 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -180,4 +180,31 @@ (lambda () (primitive-exit 42)))) +(skip-if-unsupported) +(test-assert "container-excursion*" + (call-with-temporary-directory + (lambda (root) + (define (namespaces pid) + (let ((pid (number->string pid))) + (map (lambda (ns) + (readlink (string-append "/proc/" pid "/ns/" ns))) + '("user" "ipc" "uts" "net" "pid" "mnt")))) + + (let* ((pid (run-container root '() + %namespaces 1 + (lambda () + (sleep 100)))) + (result (container-excursion* pid + (lambda () + (namespaces 1))))) + (kill pid SIGKILL) + (equal? result (namespaces pid)))))) + +(skip-if-unsupported) +(test-equal "container-excursion*, same namespaces" + 42 + (container-excursion* (getpid) + (lambda () + (* 6 7)))) + (test-end) -- cgit v1.2.3 From 63302a4e55241a41eab4c21d7af9fbd0d5817459 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Feb 2017 23:47:09 +0100 Subject: Add (gnu build shepherd). * gnu/build/shepherd.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. --- gnu/build/shepherd.scm | 177 +++++++++++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 1 + 2 files changed, 178 insertions(+) create mode 100644 gnu/build/shepherd.scm (limited to 'gnu/build') diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm new file mode 100644 index 0000000000..8fc74bc482 --- /dev/null +++ b/gnu/build/shepherd.scm @@ -0,0 +1,177 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès +;;; +;;; 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 . + +(define-module (gnu build shepherd) + #:use-module (gnu system file-systems) + #:use-module (gnu build linux-container) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:export (make-forkexec-constructor/container)) + +;;; Commentary: +;;; +;;; This module provides extensions to the GNU Shepherd. In particular, it +;;; provides a helper to start services in a container. +;;; +;;; Code: + +(define (clean-up file) + (when file + (catch 'system-error + (lambda () + (delete-file file)) + (lambda args + (unless (= ENOENT (system-error-errno args)) + (apply throw args)))))) + +(define-syntax-rule (catch-system-error exp) + (catch 'system-error + (lambda () + exp) + (const #f))) + +(define (default-namespaces args) + ;; Most daemons are here to talk to the network, and most of them expect to + ;; run under a non-zero UID. + (fold delq %namespaces '(net user))) + +(define* (default-mounts #:key (namespaces (default-namespaces '()))) + (define (tmpfs directory) + (file-system + (device "none") + (title 'device) + (mount-point directory) + (type "tmpfs") + (check? #f))) + + (define passwd + ;; This is for processes in the default user namespace but living in a + ;; different mount namespace, so that they can lookup users. + (file-system-mapping + (source "/etc/passwd") (target source))) + + (define nscd-socket + (file-system-mapping + (source "/var/run/nscd") (target source) + (writable? #t))) + + (append (cons (tmpfs "/tmp") %container-file-systems) + (let ((mappings `(,@(if (memq 'net namespaces) + '() + (cons nscd-socket + %network-file-mappings)) + ,@(if (and (memq 'mnt namespaces) + (not (memq 'user namespaces))) + (list passwd) + '()) + ,%store-mapping))) ;XXX: coarse-grain + (map file-system-mapping->bind-mount + (filter (lambda (mapping) + (file-exists? (file-system-mapping-source mapping))) + mappings))))) + +;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency. +(module-autoload! (current-module) + '(shepherd service) '(read-pid-file exec-command)) + +(define* (read-pid-file/container pid pid-file #:key (max-delay 5)) + "Read PID-FILE in the container namespaces of PID, which exists in a +separate mount and PID name space. Return the \"outer\" PID. " + (match (container-excursion* pid + (lambda () + (read-pid-file pid-file + #:max-delay max-delay))) + (#f + (catch-system-error (kill pid SIGTERM)) + #f) + ((? integer? container-pid) + ;; XXX: When COMMAND is started in a separate PID namespace, its + ;; PID is always 1, but that's not what Shepherd needs to know. + pid))) + +(define* (make-forkexec-constructor/container command + #:key + (namespaces + (default-namespaces args)) + (mappings '()) + (user #f) + (group #f) + (log-file #f) + pid-file + (pid-file-timeout 5) + (directory "/") + (environment-variables + (environ)) + #:rest args) + "This is a variant of 'make-forkexec-constructor' that starts COMMAND in +NAMESPACES, a list of Linux namespaces such as '(mnt ipc). MAPPINGS is the +list of to make in the case of a separate mount +namespace, in addition to essential bind-mounts such /proc." + (define container-directory + (match command + ((program _ ...) + (string-append "/var/run/containers/" (basename program))))) + + (define auto-mappings + `(,@(if log-file + (list (file-system-mapping + (source log-file) + (target source) + (writable? #t))) + '()))) + + (define mounts + (append (map file-system-mapping->bind-mount + (append auto-mappings mappings)) + (default-mounts #:namespaces namespaces))) + + (lambda args + (mkdir-p container-directory) + + (when log-file + ;; Create LOG-FILE so we can map it in the container. + (unless (file-exists? log-file) + (call-with-output-file log-file (const #t)))) + + (let ((pid (run-container container-directory + mounts namespaces 1 + (lambda () + (mkdir-p "/var/run") + (clean-up pid-file) + (clean-up log-file) + + (exec-command command + #:user user + #:group group + #:log-file log-file + #:directory directory + #:environment-variables + environment-variables))))) + (if pid-file + (if (or (memq 'mnt namespaces) (memq 'pid namespaces)) + (read-pid-file/container pid pid-file + #:max-delay pid-file-timeout) + (read-pid-file pid-file #:max-delay pid-file-timeout)) + pid)))) + +;; Local Variables: +;; eval: (put 'container-excursion* 'scheme-indent-function 1) +;; End: + +;;; shepherd.scm ends here diff --git a/gnu/local.mk b/gnu/local.mk index 5c1634e021..63ce3af713 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -451,6 +451,7 @@ GNU_SYSTEM_MODULES = \ %D%/build/linux-initrd.scm \ %D%/build/linux-modules.scm \ %D%/build/marionette.scm \ + %D%/build/shepherd.scm \ %D%/build/svg.scm \ %D%/build/vm.scm \ \ -- cgit v1.2.3 From 387e175492f960d7d86f34f3b2e43938fa72dbf3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Feb 2017 15:32:28 +0100 Subject: services: Add 'special-files-service-type'. * gnu/build/activation.scm (activate-/bin/sh): Remove. (activate-special-files): New procedure. * gnu/services.scm (activation-script): Remove call to 'activate-/bin/sh'. (special-files-service-type): New variable. (extra-special-file): New procedure. * gnu/services/base.scm (%base-services): Add SPECIAL-FILES-SERVICE-TYPE instance. * gnu/tests/base.scm (run-basic-test)[special-files]: New variables. ["special files"]: New test. --- doc/guix.texi | 44 ++++++++++++++++++++++++++++++++++++++++++++ gnu/build/activation.scm | 23 ++++++++++++++++++----- gnu/services.scm | 25 +++++++++++++++++++++---- gnu/services/base.scm | 7 ++++++- gnu/tests/base.scm | 17 +++++++++++++++++ 5 files changed, 106 insertions(+), 10 deletions(-) (limited to 'gnu/build') diff --git a/doc/guix.texi b/doc/guix.texi index 6acde6621b..21082aece4 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -8272,6 +8272,50 @@ this: @end example @end defvr +@defvr {Scheme Variable} special-files-service-type +This is the service that sets up ``special files'' such as +@file{/bin/sh}; an instance of it is part of @code{%base-services}. + +The value associated with @code{special-files-service-type} services +must be a list of tuples where the first element is the ``special file'' +and the second element is its target. By default it is: + +@cindex @file{/bin/sh} +@cindex @file{sh}, in @file{/bin} +@example +`(("/bin/sh" ,(file-append @var{bash} "/bin/sh"))) +@end example + +@cindex @file{/usr/bin/env} +@cindex @file{env}, in @file{/usr/bin} +If you want to add, say, @code{/usr/bin/env} to your system, you can +change it to: + +@example +`(("/bin/sh" ,(file-append @var{bash} "/bin/sh")) + ("/usr/bin/env" ,(file-append @var{coreutils} "/bin/env"))) +@end example + +Since this is part of @code{%base-services}, you can use +@code{modify-services} to customize the set of special files +(@pxref{Service Reference, @code{modify-services}}). But the simple way +to add a special file is @i{via} the @code{extra-special-file} procedure +(see below.) +@end defvr + +@deffn {Scheme Procedure} extra-special-file @var{file} @var{target} +Use @var{target} as the ``special file'' @var{file}. + +For example, adding the following lines to the @code{services} field of +your operating system declaration leads to a @file{/usr/bin/env} +symlink: + +@example +(extra-special-file "/usr/bin/env" + (file-append coreutils "/bin/env")) +@end example +@end deffn + @deffn {Scheme Procedure} host-name-service @var{name} Return a service that sets the host name to @var{name}. @end deffn diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index e58304e83b..c4ed40e0de 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -28,7 +28,7 @@ activate-user-home activate-etc activate-setuid-programs - activate-/bin/sh + activate-special-files activate-modprobe activate-firmware activate-ptrace-attach @@ -383,10 +383,23 @@ copy SOURCE to TARGET." (for-each make-setuid-program programs)) -(define (activate-/bin/sh shell) - "Change /bin/sh to point to SHELL." - (symlink shell "/bin/sh.new") - (rename-file "/bin/sh.new" "/bin/sh")) +(define (activate-special-files special-files) + "Install the files listed in SPECIAL-FILES. Each element of SPECIAL-FILES +is a pair where the first element is the name of the special file and the +second element is the name it should appear at, such as: + + ((\"/bin/sh\" \"/gnu/store/…-bash/bin/sh\") + (\"/usr/bin/env\" \"/gnu/store/…-coreutils/bin/env\")) +" + (define install-special-file + (match-lambda + ((target file) + (let ((pivot (string-append target ".new"))) + (mkdir-p (dirname target)) + (symlink file pivot) + (rename-file pivot target))))) + + (for-each install-special-file special-files)) (define (activate-modprobe modprobe) "Tell the kernel to use MODPROBE to load modules." diff --git a/gnu/services.scm b/gnu/services.scm index e645889d30..6ac4f1322d 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -72,6 +72,8 @@ activation-service-type activation-service->script %linux-bare-metal-service + special-files-service-type + extra-special-file etc-service-type etc-directory setuid-program-service-type @@ -336,10 +338,6 @@ ACTIVATION-SCRIPT-TYPE." #~(begin (use-modules (gnu build activation)) - ;; Make sure /bin/sh is valid and current. - (activate-/bin/sh - (string-append #$(canonical-package bash) "/bin/sh")) - ;; Make sure the user accounting database exists. If it ;; does not exist, 'setutxent' does not create it and ;; thus there is no accounting at all. @@ -413,6 +411,25 @@ ACTIVATION-SCRIPT-TYPE." ;; necessary or impossible in a container. (service linux-bare-metal-service-type #f)) +(define special-files-service-type + ;; Service to install "special files" such as /bin/sh and /usr/bin/env. + (service-type + (name 'special-files) + (extensions + (list (service-extension activation-service-type + (lambda (files) + #~(activate-special-files '#$files))))) + (compose concatenate) + (extend append))) + +(define (extra-special-file file target) + "Use TARGET as the \"special file\" FILE. For example, TARGET might be + (file-append coreutils \"/bin/env\") +and FILE could be \"/usr/bin/env\"." + (simple-service (string->symbol (string-append "special-file-" file)) + special-files-service-type + `((,file ,target)))) + (define (etc-directory service) "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE." (files->etc-directory (service-parameters service))) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index d9f3a1445e..57601eab85 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -36,6 +36,7 @@ #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools)) #:use-module ((gnu packages base) #:select (canonical-package glibc)) + #:use-module (gnu packages bash) #:use-module (gnu packages package-management) #:use-module (gnu packages lsof) #:use-module (gnu packages terminals) @@ -1558,6 +1559,10 @@ This service is not part of @var{%base-services}." ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is ;; used, so enable them by default. The FUSE and ALSA rules are ;; less critical, but handy. - (udev-service #:rules (list lvm2 fuse alsa-utils crda)))) + (udev-service #:rules (list lvm2 fuse alsa-utils crda)) + + (service special-files-service-type + `(("/bin/sh" ,(file-append (canonical-package bash) + "/bin/sh")))))) ;;; base.scm ends here diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 8a6a7a1568..000a4ddecb 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -77,6 +77,11 @@ When INITIALIZATION is true, it must be a one-argument procedure that is passed a gexp denoting the marionette, and it must return gexp that is inserted before the first test. This is used to introduce an extra initialization step, such as entering a LUKS passphrase." + (define special-files + (service-parameters + (fold-services (operating-system-services os) + #:target-type special-files-service-type))) + (define test (with-imported-modules '((gnu build marionette) (guix build syscalls)) @@ -120,6 +125,18 @@ grep --version info --version") marionette))) + (test-equal "special files" + '#$special-files + (marionette-eval + '(begin + (use-modules (ice-9 match)) + + (map (match-lambda + ((file target) + (list file (readlink file)))) + '#$special-files)) + marionette)) + (test-assert "accounts" (let ((users (marionette-eval '(begin (use-modules (ice-9 match)) -- cgit v1.2.3