diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/examples/docker-image.tmpl | 47 | ||||
| -rw-r--r-- | gnu/system/nss.scm | 10 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 3 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 117 |
4 files changed, 171 insertions, 6 deletions
diff --git a/gnu/system/examples/docker-image.tmpl b/gnu/system/examples/docker-image.tmpl new file mode 100644 index 0000000000..d73187398f --- /dev/null +++ b/gnu/system/examples/docker-image.tmpl @@ -0,0 +1,47 @@ +;; This is an operating system configuration template for a "Docker image" +;; setup, so it has barely any services at all. + +(use-modules (gnu)) + +(operating-system + (host-name "komputilo") + (timezone "Europe/Berlin") + (locale "en_US.utf8") + + ;; This is where user accounts are specified. The "root" account is + ;; implicit, and is initially created with the empty password. + (users (cons (user-account + (name "alice") + (comment "Bob's sister") + (group "users") + (supplementary-groups '("wheel" + "audio" "video")) + (home-directory "/home/alice")) + %base-user-accounts)) + + ;; Globally-installed packages. + (packages %base-packages) + + ;; Because the system will run in a Docker container, we may omit many + ;; things that would normally be required in an operating system + ;; configuration file. These things include: + ;; + ;; * bootloader + ;; * file-systems + ;; * services such as mingetty, udevd, slim, networking, dhcp + ;; + ;; Either these things are simply not required, or Docker provides + ;; similar services for us. + + ;; This will be ignored. + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "does-not-matter"))) + ;; This will be ignored, too. + (file-systems (list (file-system + (device "does-not-matter") + (mount-point "/") + (type "does-not-matter")))) + + ;; Guix is all you need! + (services (list (guix-service)))) diff --git a/gnu/system/nss.scm b/gnu/system/nss.scm index f4d2855289..673b96c713 100644 --- a/gnu/system/nss.scm +++ b/gnu/system/nss.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -93,6 +93,8 @@ ;;; (define %compat + ;; Note: Starting from version 2.26, libc no longer provides libnss_compat + ;; so this specification has become useless. (name-service (name "compat") (reaction (lookup-specification (not-found => return))))) @@ -124,7 +126,7 @@ (ethers name-service-switch-ethers (default '())) (group name-service-switch-group - (default (list %compat %files))) + (default (list %files))) (gshadow name-service-switch-gshadow (default '())) (hosts name-service-switch-hosts @@ -136,7 +138,7 @@ (networks name-service-switch-networks (default (list %files %dns))) (password name-service-switch-password - (default (list %compat %files))) + (default (list %files))) (public-key name-service-switch-public-key (default '())) (rpc name-service-switch-rpc @@ -144,7 +146,7 @@ (services name-service-switch-services (default '())) (shadow name-service-switch-shadow - (default (list %compat %files)))) + (default (list %files)))) (define %default-nss ;; Default NSS configuration. diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index 119f7e4d0b..ef5b8dab92 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -195,6 +195,9 @@ set auto-load safe-path /gnu/store/*/lib\n"))) `((".bash_profile" ,profile) (".bashrc" ,bashrc) (".zlogin" ,zlogin) + (".nanorc" ,(plain-file "nanorc" "\ +# Include all the syntax highlighting modules. +include /run/current-system/profile/share/nano/*.nanorc\n")) (".Xdefaults" ,xdefaults) (".guile" ,(plain-file "dot-guile" "(cond ((false-if-exception (resolve-interface '(ice-9 readline))) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 594ba66ff4..09a11af863 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> +;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,7 @@ (define-module (gnu system vm) #:use-module (guix config) + #:use-module (guix docker) #:use-module (guix store) #:use-module (guix gexp) #:use-module (guix derivations) @@ -29,6 +31,7 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix modules) + #:use-module (guix scripts pack) #:use-module (guix utils) #:use-module (guix hash) #:use-module (guix base32) @@ -38,7 +41,9 @@ #:use-module (gnu packages base) #:use-module (gnu packages bootloaders) #:use-module (gnu packages cdrom) + #:use-module (gnu packages compression) #:use-module (gnu packages guile) + #:autoload (gnu packages gnupg) (libgcrypt) #:use-module (gnu packages gawk) #:use-module (gnu packages bash) #:use-module (gnu packages less) @@ -75,6 +80,7 @@ system-qemu-image/shared-store system-qemu-image/shared-store-script system-disk-image + system-docker-image virtual-machine virtual-machine?)) @@ -87,8 +93,8 @@ ;;; Code: (define %linux-vm-file-systems - ;; File systems mounted for 'derivation-in-linux-vm'. The store and /xchg - ;; directory are shared with the host over 9p. + ;; File systems mounted for 'derivation-in-linux-vm'. These are shared with + ;; the host over 9p. (list (file-system (mount-point (%store-prefix)) (device "store") @@ -102,6 +108,13 @@ (type "9p") (needed-for-boot? #t) (options "trans=virtio") + (check? #f)) + (file-system + (mount-point "/tmp") + (device "tmp") + (type "9p") + (needed-for-boot? #t) + (options "trans=virtio") (check? #f)))) (define* (expression->derivation-in-linux-vm name exp @@ -369,6 +382,106 @@ the image." #:disk-image-format disk-image-format #:references-graphs inputs)) +(define* (system-docker-image os + #:key + (name "guixsd-docker-image") + register-closures?) + "Build a docker image. OS is the desired <operating-system>. NAME is the +base name to use for the output file. When REGISTER-CLOSURES? is not #f, +register the closure of OS with Guix in the resulting Docker image. This only +makes sense when you want to build a GuixSD Docker image that has Guix +installed inside of it. If you don't need Guix (e.g., your GuixSD Docker +image just contains a web server that is started by the Shepherd), then you +should set REGISTER-CLOSURES? to #f." + (define not-config? + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (rest #f))) + + (define config + ;; (guix config) module for consumption by (guix gcrypt). + (scheme-file "gcrypt-config.scm" + #~(begin + (define-module (guix config) + #:export (%libgcrypt)) + + ;; XXX: Work around <http://bugs.gnu.org/15602>. + (eval-when (expand load eval) + (define %libgcrypt + #+(file-append libgcrypt "/lib/libgcrypt")))))) + (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) + (name -> (string-append name ".tar.gz")) + (graph -> "system-graph")) + (define build + (with-imported-modules `(,@(source-module-closure '((guix docker) + (guix build utils) + (gnu build vm)) + #:select? not-config?) + (guix build store-copy) + ((guix config) => ,config)) + #~(begin + ;; Guile-JSON is required by (guix docker). + (add-to-load-path + (string-append #+guile-json "/share/guile/site/" + (effective-version))) + (use-modules (guix docker) + (guix build utils) + (gnu build vm) + (srfi srfi-19) + (guix build store-copy)) + + (let* ((inputs '#$(append (list tar) + (if register-closures? + (list guix) + '()))) + ;; This initializer requires elevated privileges that are + ;; not normally available in the build environment (e.g., + ;; it needs to create device nodes). In order to obtain + ;; such privileges, we run it as root in a VM. + (initialize (root-partition-initializer + #:closures '(#$graph) + #:register-closures? #$register-closures? + #:system-directory #$os-drv + ;; De-duplication would fail due to + ;; cross-device link errors, so don't do it. + #:deduplicate? #f)) + ;; Even as root in a VM, the initializer would fail due to + ;; lack of privileges if we use a root-directory that is on + ;; a file system that is shared with the host (e.g., /tmp). + (root-directory "/guixsd-system-root")) + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (mkdir root-directory) + (initialize root-directory) + (build-docker-image + (string-append "/xchg/" #$name) ;; The output file. + (cons* root-directory + (call-with-input-file (string-append "/xchg/" #$graph) + read-reference-graph)) + #$os-drv + #:compressor '(#+(file-append gzip "/bin/gzip") "-9n") + #:creation-time (make-time time-utc 0 1) + #:transformations `((,root-directory -> ""))))))) + (expression->derivation-in-linux-vm + name + ;; The VM's initrd Guile doesn't support dlopen, but our "build" gexp + ;; needs to be run by a Guile that can dlopen libgcrypt. The following + ;; hack works around that problem by putting the "build" gexp into an + ;; executable script (created by program-file) which, when executed, will + ;; run using a Guile that supports dlopen. That way, the VM's initrd + ;; Guile can just execute it via invoke, without using dlopen. See: + ;; https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00233.html + (with-imported-modules `((guix build utils)) + #~(begin + (use-modules (guix build utils)) + ;; If we use execl instead of invoke here, the VM will crash with a + ;; kernel panic. + (invoke #$(program-file "build-docker-image" build)))) + #:make-disk-image? #f + #:single-file-output? #t + #:references-graphs `((,graph ,os-drv))))) + ;;; ;;; VM and disk images. |