aboutsummaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/activation.scm62
-rw-r--r--gnu/build/file-systems.scm33
-rw-r--r--gnu/build/linux-container.scm40
-rw-r--r--gnu/build/shepherd.scm177
4 files changed, 286 insertions, 26 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 1b31dc1538..c4ed40e0de 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -25,9 +25,10 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (activate-users+groups
+ activate-user-home
activate-etc
activate-setuid-programs
- activate-/bin/sh
+ activate-special-files
activate-modprobe
activate-firmware
activate-ptrace-attach
@@ -84,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<?)))
(mkdir-p home)
+ (set-owner home)
(for-each (lambda (file)
(let ((target (string-append home "/" file)))
(copy-recursively (string-append directory "/" file)
target
#:log (%make-void-port "w"))
+ (for-each set-owner
+ (find-files target (const #t)
+ #:directories? #t))
(make-file-writable target)))
files)))
@@ -220,7 +232,7 @@ numeric gid or #f."
#:supplementary-groups supplementary-groups
#:comment comment
#:home home
- #:create-home? create-home?
+ #:create-home? (and create-home? system?)
#:shell shell
#:password password)
@@ -268,6 +280,25 @@ numeric gid or #f."
(((names . _) ...)
names)))))
+(define (activate-user-home users)
+ "Create and populate the home directory of USERS, a list of tuples, unless
+they already exist."
+ (define ensure-user-home
+ (match-lambda
+ ((name uid group supplementary-groups comment home create-home?
+ shell password system?)
+ (unless (or (not home) (directory-exists? home))
+ (let* ((pw (getpwnam name))
+ (uid (passwd:uid pw))
+ (gid (passwd:gid pw)))
+ (mkdir-p home)
+ (chown home uid gid)
+ (unless system?
+ (copy-account-skeletons home
+ #:uid uid #:gid gid)))))))
+
+ (for-each ensure-user-home users))
+
(define (activate-etc etc)
"Install ETC, a directory in the store, as the source of static files for
/etc."
@@ -352,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/build/file-systems.scm b/gnu/build/file-systems.scm
index 6e5c6aaf15..f8ab95370c 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
;;;
;;; This file is part of GNU Guix.
@@ -72,22 +72,33 @@
"Bind-mount SOURCE at TARGET."
(mount source target "" MS_BIND))
+(define (seek* fd/port offset whence)
+ "Like 'seek' but return -1 instead of throwing to 'system-error' upon
+EINVAL. This makes it easier to catch cases like OFFSET being too large for
+FD/PORT."
+ (catch 'system-error
+ (lambda ()
+ (seek fd/port offset whence))
+ (lambda args
+ (if (= EINVAL (system-error-errno args))
+ -1
+ (apply throw args)))))
+
(define (read-superblock device offset size magic?)
"Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
superblock on success, and #f if no valid superblock was found. MAGIC?
takes a bytevector and returns #t when it's a valid superblock."
(call-with-input-file device
(lambda (port)
- (seek port offset SEEK_SET)
-
- (let ((block (make-bytevector size)))
- (match (get-bytevector-n! port block 0 (bytevector-length block))
- ((? eof-object?)
- #f)
- ((? number? len)
- (and (= len (bytevector-length block))
- (and (magic? block)
- block))))))))
+ (and (= offset (seek* port offset SEEK_SET))
+ (let ((block (make-bytevector size)))
+ (match (get-bytevector-n! port block 0 (bytevector-length block))
+ ((? eof-object?)
+ #f)
+ ((? number? len)
+ (and (= len (bytevector-length block))
+ (and (magic? block)
+ block)))))))))
(define (sub-bytevector bv start size)
"Return a copy of the SIZE bytes of BV starting from offset START."
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index b71d6a5f88..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 <davet@gnu.org>
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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."
@@ -128,13 +130,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"))
@@ -229,6 +237,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.
@@ -318,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/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 <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 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 <file-system-mapping> 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
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-14 02:42:20 +0000