aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/system.scm109
-rw-r--r--gnu/system/linux-container.scm84
-rw-r--r--guix/scripts/system.scm18
3 files changed, 147 insertions, 64 deletions
diff --git a/gnu/system.scm b/gnu/system.scm
index ad0c9e57dc..e9310e3d5b 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -445,32 +445,40 @@ OS."
(file-append (operating-system-kernel os)
"/" (system-linux-image-file-name os)))
-(define* (operating-system-directory-base-entries os)
+(define* (operating-system-directory-base-entries os #:key container?)
"Return the basic entries of the 'system' directory of OS for use as the
value of the SYSTEM-SERVICE-TYPE service."
(let ((locale (operating-system-locale-directory os)))
- (mlet %store-monad ((kernel -> (operating-system-kernel os))
- (initrd -> (operating-system-initrd-file os))
- (params (operating-system-boot-parameters-file os)))
- (return `(("kernel" ,kernel)
- ("parameters" ,params)
- ("initrd" ,initrd)
- ("locale" ,locale)))))) ;used by libc
-
-(define* (essential-services os)
+ (with-monad %store-monad
+ (if container?
+ (return `(("locale" ,locale)))
+ (mlet %store-monad
+ ((kernel -> (operating-system-kernel os))
+ (initrd -> (operating-system-initrd-file os))
+ (params (operating-system-boot-parameters-file os)))
+ (return `(("kernel" ,kernel)
+ ("parameters" ,params)
+ ("initrd" ,initrd)
+ ("locale" ,locale)))))))) ;used by libc
+
+(define* (essential-services os #:key container? container-shared-network?)
"Return the list of essential services for OS. These are special services
that implement part of what's declared in OS are responsible for low-level
bookkeeping."
(define known-fs
(map file-system-mount-point (operating-system-file-systems os)))
+ (if (and container-shared-network? (not container?))
+ (error "cannot specify container-shared-network? without container? #t"))
+
(let* ((mappings (device-mapping-services os))
(root-fs (root-file-system-service))
(other-fs (non-boot-file-system-service os))
(swaps (swap-services os))
(procs (service user-processes-service-type))
(host-name (host-name-service (operating-system-host-name os)))
- (entries (operating-system-directory-base-entries os)))
+ (entries (operating-system-directory-base-entries
+ os #:container? container?)))
(cons* (service system-service-type entries)
%boot-service
@@ -486,7 +494,8 @@ bookkeeping."
(account-service (append (operating-system-accounts os)
(operating-system-groups os))
(operating-system-skeletons os))
- (operating-system-etc-service os)
+ (operating-system-etc-service
+ os #:container-shared-network? container-shared-network?)
(service fstab-service-type '())
(session-environment-service
(operating-system-environment-variables os))
@@ -498,16 +507,23 @@ bookkeeping."
other-fs
(append mappings swaps
- ;; Add the firmware service.
- (list %linux-bare-metal-service
- (service firmware-service-type
- (operating-system-firmware os)))))))
-
-(define* (operating-system-services os)
- "Return all the services of OS, including \"essential\" services."
+ ;; Add the firmware service, unless we are building for a
+ ;; container.
+ (if container?
+ (list %containerized-shepherd-service)
+ (list %linux-bare-metal-service
+ (service firmware-service-type
+ (operating-system-firmware os))))))))
+
+(define* (operating-system-services os #:key container? container-shared-network?)
+ "Return all the services of OS, including \"internal\" services that do not
+explicitly appear in OS."
(instantiate-missing-services
(append (operating-system-user-services os)
- (operating-system-essential-services os))))
+ (essential-services
+ os
+ #:container? container?
+ #:container-shared-network? container-shared-network?))))
;;;
@@ -576,7 +592,7 @@ This is the GNU system. Welcome.\n")
"Return the default /etc/hosts file."
(plain-file "hosts" (local-host-aliases host-name)))
-(define* (operating-system-etc-service os)
+(define* (operating-system-etc-service os #:key container-shared-network?)
"Return a <service> that builds containing the static part of the /etc
directory."
(let ((login.defs
@@ -678,24 +694,23 @@ then
source /run/current-system/profile/etc/profile.d/bash_completion.sh
fi\n")))
(etc-service
- `(("services" ,(file-append net-base "/etc/services"))
- ("protocols" ,(file-append net-base "/etc/protocols"))
+ `(("protocols" ,(file-append net-base "/etc/protocols"))
("rpc" ,(file-append net-base "/etc/rpc"))
("login.defs" ,#~#$login.defs)
("issue" ,#~#$issue)
("nsswitch.conf" ,#~#$nsswitch)
("profile" ,#~#$profile)
("bashrc" ,#~#$bashrc)
- ("hosts" ,#~#$(or (operating-system-hosts-file os)
- (default-/etc/hosts (operating-system-host-name os))))
- ;; Write the operating-system-host-name to /etc/hostname to prevent
- ;; NetworkManager from changing the system's hostname when connecting
- ;; to certain networks. Some discussion at
- ;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html
("hostname" ,(plain-file "hostname" (operating-system-host-name os)))
("localtime" ,(file-append tzdata "/share/zoneinfo/"
(operating-system-timezone os)))
- ("sudoers" ,(operating-system-sudoers-file os))))))
+ ("sudoers" ,(operating-system-sudoers-file os))
+ ,@(if container-shared-network?
+ '()
+ `(("services" ,(file-append net-base "/etc/services"))
+ ("hosts" ,#~#$(or (operating-system-hosts-file os)
+ (default-/etc/hosts
+ (operating-system-host-name os))))))))))
(define %root-account
;; Default root account.
@@ -805,19 +820,28 @@ use 'plain-file' instead~%")
root ALL=(ALL) ALL
%wheel ALL=(ALL) ALL\n"))
-(define* (operating-system-activation-script os)
+(define* (operating-system-activation-script os #:key container?
+ container-shared-network?)
"Return the activation script for OS---i.e., the code that \"activates\" the
stateful part of OS, including user accounts and groups, special directories,
etc."
- (let* ((services (operating-system-services os))
+ (let* ((services (operating-system-services
+ os
+ #:container? container?
+ #:container-shared-network? container-shared-network?))
(activation (fold-services services
#:target-type activation-service-type)))
(activation-service->script activation)))
-(define* (operating-system-boot-script os)
+(define* (operating-system-boot-script os #:key container?
+ container-shared-network?)
"Return the boot script for OS---i.e., the code started by the initrd once
-we're running in the final root."
- (let* ((services (operating-system-services os))
+we're running in the final root. When CONTAINER? is true, skip all
+hardware-related operations as necessary when booting a Linux container."
+ (let* ((services (operating-system-services
+ os
+ #:container? container?
+ #:container-shared-network? container-shared-network?))
(boot (fold-services services #:target-type boot-service-type)))
(service-value boot)))
@@ -837,17 +861,24 @@ we're running in the final root."
#:target-type
shepherd-root-service-type))))
-(define* (operating-system-derivation os)
+(define* (operating-system-derivation os #:key container?
+ container-shared-network?)
"Return a derivation that builds OS."
- (let* ((services (operating-system-services os))
+ (let* ((services (operating-system-services
+ os
+ #:container? container?
+ #:container-shared-network? container-shared-network?))
(system (fold-services services)))
;; SYSTEM contains the derivation as a monadic value.
(service-value system)))
-(define* (operating-system-profile os)
+(define* (operating-system-profile os #:key container? container-shared-network?)
"Return a derivation that builds the system profile of OS."
(mlet* %store-monad
- ((services -> (operating-system-services os))
+ ((services -> (operating-system-services
+ os
+ #:container? container?
+ #:container-shared-network? container-shared-network?))
(profile (fold-services services
#:target-type profile-service-type)))
(match profile
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index 37a053cdc3..48d6df4348 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -93,35 +93,73 @@ containerized OS."
%container-file-systems
user-file-systems))))
-(define* (container-script os #:key (mappings '()))
+
+(define %network-configuration-files
+ '("/etc/resolv.conf"
+ "/etc/services"
+ "/etc/hosts"))
+
+(define* (container-script os #:key (mappings '())
+ container-shared-network?)
"Return a derivation of a script that runs OS as a Linux container.
MAPPINGS is a list of <file-system> objects that specify the files/directories
that will be shared with the host system."
- (let* ((os (containerized-operating-system os mappings))
+ (let* ((os (containerized-operating-system
+ os
+ (append
+ mappings
+ (if
+ container-shared-network?
+ (filter-map (lambda (file)
+ (and (file-exists? file)
+ (file-system-mapping
+ (source file)
+ (target file)
+ ;; XXX: On some GNU/Linux
+ ;; systems, /etc/resolv.conf is a
+ ;; symlink to a file in a tmpfs
+ ;; which, for an unknown reason,
+ ;; cannot be bind mounted
+ ;; read-only within the
+ ;; container.
+ (writable?
+ (string=?
+ file "/etc/resolv.conf")))))
+ %network-configuration-files)
+ '()))))
(file-systems (filter file-system-needed-for-boot?
(operating-system-file-systems os)))
(specs (map file-system->spec file-systems)))
- (define script
- (with-imported-modules (source-module-closure
- '((guix build utils)
- (gnu build linux-container)))
- #~(begin
- (use-modules (gnu build linux-container)
- (gnu system file-systems) ;spec->file-system
- (guix build utils))
+ (mlet* %store-monad ((os-drv
+ (operating-system-derivation
+ os
+ #:container? #t
+ #:container-shared-network? container-shared-network?)))
+
+ (define script
+ (with-imported-modules (source-module-closure
+ '((guix build utils)
+ (gnu build linux-container)))
+ #~(begin
+ (use-modules (gnu build linux-container)
+ (gnu system file-systems) ;spec->file-system
+ (guix build utils))
- (call-with-container (map spec->file-system '#$specs)
- (lambda ()
- (setenv "HOME" "/root")
- (setenv "TMPDIR" "/tmp")
- (setenv "GUIX_NEW_SYSTEM" #$os)
- (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
- (primitive-load (string-append #$os "/boot")))
- ;; A range of 65536 uid/gids is used to cover 16 bits worth of
- ;; users and groups, which is sufficient for most cases.
- ;;
- ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
- #:host-uids 65536))))
+ (call-with-container (map spec->file-system '#$specs)
+ (lambda ()
+ (setenv "HOME" "/root")
+ (setenv "TMPDIR" "/tmp")
+ (setenv "GUIX_NEW_SYSTEM" #$os-drv)
+ (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
+ (primitive-load (string-append #$os-drv "/boot")))
+ ;; A range of 65536 uid/gids is used to cover 16 bits worth of
+ ;; users and groups, which is sufficient for most cases.
+ ;;
+ ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
+ #:host-uids 65536
+ #:namespaces (if #$container-shared-network?
+ (delq 'net %namespaces)
+ %namespaces)))))
- (gexp->script "run-container" script)))
+ (gexp->script "run-container" script))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 78aa6cf644..cd6e7eeb92 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -756,13 +756,15 @@ checking this by themselves in their 'check' procedure."
(define* (system-derivation-for-action os action
#:key image-size file-system-type
- full-boot? mappings)
+ full-boot? mappings
+ container-shared-network?)
"Return as a monadic value the derivation for OS according to ACTION."
(case action
((build init reconfigure)
(operating-system-derivation os))
((container)
- (container-script os #:mappings mappings))
+ (container-script os #:mappings mappings
+ #:container-shared-network? container-shared-network?))
((vm-image)
(system-qemu-image os #:disk-image-size image-size))
((vm)
@@ -826,6 +828,7 @@ and TARGET arguments."
dry-run? derivations-only?
use-substitutes? bootloader-target target
image-size file-system-type full-boot?
+ container-shared-network?
(mappings '())
(gc-root #f))
"Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install
@@ -834,6 +837,8 @@ target root directory; IMAGE-SIZE is the size of the image to be built, for
the 'vm-image' and 'disk-image' actions. The root file system is created as a
FILE-SYSTEM-TYPE file system. FULL-BOOT? is used for the 'vm' action; it
determines whether to boot directly to the kernel or to the bootloader.
+CONTAINER-SHARED_NETWORK? determines if the container will use a use a
+separate network namespace.
When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
building anything.
@@ -883,6 +888,7 @@ static checks."
#:file-system-type file-system-type
#:image-size image-size
#:full-boot? full-boot?
+ #:container-shared-network? container-shared-network?
#:mappings mappings))
;; For 'init' and 'reconfigure', always build BOOTCFG, even if
@@ -1020,6 +1026,8 @@ Some ACTIONS support additional ARGS.\n"))
(display (G_ "
--share=SPEC for 'vm', share host file system according to SPEC"))
(display (G_ "
+ -N, --network for 'container', allow containers to access the network"))
+ (display (G_ "
-r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container',
and 'build', make FILE a symlink to the result, and
register it as a garbage collector root"))
@@ -1066,6 +1074,9 @@ Some ACTIONS support additional ARGS.\n"))
(lambda (opt name arg result)
(alist-cons 'image-size (size->number arg)
result)))
+ (option '(#\N "network") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'container-shared-network? #t result)))
(option '("no-bootloader" "no-grub") #f #f
(lambda (opt name arg result)
(alist-cons 'install-bootloader? #f result)))
@@ -1182,6 +1193,9 @@ resulting from command-line parsing."
#:file-system-type (assoc-ref opts 'file-system-type)
#:image-size (assoc-ref opts 'image-size)
#:full-boot? (assoc-ref opts 'full-boot?)
+ #:container-shared-network? (assoc-ref
+ opts
+ 'container-shared-network?)
#:mappings (filter-map (match-lambda
(('file-system-mapping . m)
m)