123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180 |
- (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))
- (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)
-
-
- (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 accounts
-
-
- (list (file-system-mapping
- (source "/etc/passwd") (target source))
- (file-system-mapping
- (source "/etc/group") (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)))
- accounts
- '())
- ,%store-mapping)))
- (map file-system-mapping->bind-mount
- (filter (lambda (mapping)
- (file-exists? (file-system-mapping-source mapping)))
- mappings)))))
- (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)
-
-
- 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
-
- (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))))
|