aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/system.scm61
-rw-r--r--gnu/system/linux-container.scm47
-rw-r--r--guix/scripts/system.scm18
3 files changed, 99 insertions, 27 deletions
diff --git a/gnu/system.scm b/gnu/system.scm
index 39452304ba..87fb12dc39 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -437,7 +437,7 @@ value of the SYSTEM-SERVICE-TYPE service."
("initrd" ,initrd)
("locale" ,locale)))))))) ;used by libc
-(define* (essential-services os #:key container?)
+(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. CONTAINER? determines whether to return the list of services for
@@ -445,6 +445,9 @@ a container or that of a \"bare metal\" system."
(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))
@@ -469,7 +472,8 @@ a container or that of a \"bare metal\" system."
(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))
@@ -489,12 +493,13 @@ a container or that of a \"bare metal\" system."
(service firmware-service-type
(operating-system-firmware os))))))))
-(define* (operating-system-services os #:key container?)
+(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)
- (essential-services os #:container? container?))))
+ (essential-services os #:container? container?
+ #:container-shared-network? container-shared-network?))))
;;;
@@ -562,7 +567,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 (plain-file "login.defs" "# Empty for now.\n"))
@@ -648,16 +653,12 @@ 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
@@ -665,7 +666,14 @@ fi\n")))
("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"))
+ ("nsswitch.conf" ,#~#$nsswitch)
+ ("hosts" ,#~#$(or (operating-system-hosts-file os)
+ (default-/etc/hosts
+ (operating-system-host-name os))))))))))
(define %root-account
;; Default root account.
@@ -774,20 +782,28 @@ use 'plain-file' instead~%")
root ALL=(ALL) ALL
%wheel ALL=(ALL) ALL\n"))
-(define* (operating-system-activation-script os #:key container?)
+(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 #:container? container?))
+ (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 #:key container?)
+(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. When CONTAINER? is true, skip all
hardware-related operations as necessary when booting a Linux container."
- (let* ((services (operating-system-services os #:container? container?))
+ (let* ((services (operating-system-services
+ os
+ #:container? container?
+ #:container-shared-network? container-shared-network?))
(boot (fold-services services #:target-type boot-service-type)))
;; BOOT is the script as a monadic value.
(service-value boot)))
@@ -808,17 +824,24 @@ hardware-related operations as necessary when booting a Linux container."
#:target-type
shepherd-root-service-type))))
-(define* (operating-system-derivation os #:key container?)
+(define* (operating-system-derivation os #:key container?
+ container-shared-network?)
"Return a derivation that builds OS."
- (let* ((services (operating-system-services os #:container? container?))
+ (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 #:key container?)
+(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 #:container? container?))
+ ((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 bceea41332..538b1f19cb 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -60,18 +60,50 @@ containerized OS."
%container-file-systems
user-file-systems))))
-(define* (container-script os #:key (mappings '()))
+
+(define %network-configuration-files
+ '("/etc/resolv.conf"
+ "/etc/nsswitch.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)))
- (mlet* %store-monad ((os-drv (operating-system-derivation
- os
- #:container? #t)))
+ (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
@@ -93,6 +125,9 @@ that will be shared with the host system."
;; 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))))
+ #:host-uids 65536
+ #:namespaces (if #$container-shared-network?
+ (delq 'net %namespaces)
+ %namespaces)))))
(gexp->script "run-container" script))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 999ffb010b..cced8d03da 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -647,13 +647,15 @@ procedure of its type."
(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)
@@ -706,6 +708,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
@@ -714,6 +717,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.
@@ -739,6 +744,7 @@ output when building a system derivation, such as a disk image."
#:file-system-type file-system-type
#:image-size image-size
#:full-boot? full-boot?
+ #:container-shared-network? container-shared-network?
#:mappings mappings))
(bootloader -> (bootloader-configuration-bootloader
(operating-system-bootloader os)))
@@ -894,6 +900,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"))
@@ -936,6 +944,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)))
@@ -1038,6 +1049,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)