diff options
Diffstat (limited to 'gnu/services')
| -rw-r--r-- | gnu/services/base.scm | 96 | ||||
| -rw-r--r-- | gnu/services/monitoring.scm | 91 | ||||
| -rw-r--r-- | gnu/services/virtualization.scm | 267 |
3 files changed, 426 insertions, 28 deletions
diff --git a/gnu/services/base.scm b/gnu/services/base.scm index f4681c804d..8e30bcd341 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com> @@ -1434,10 +1434,14 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (default #t)) (substitute-urls guix-configuration-substitute-urls ;list of strings (default %default-substitute-urls)) + (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings + (default '())) (max-silent-time guix-configuration-max-silent-time ;integer (default 0)) (timeout guix-configuration-timeout ;integer (default 0)) + (log-compression guix-configuration-log-compression + (default 'bzip2)) (extra-options guix-configuration-extra-options ;list of strings (default '())) (log-file guix-configuration-log-file ;string @@ -1452,39 +1456,49 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (define (guix-shepherd-service config) "Return a <shepherd-service> for the Guix daemon service with CONFIG." - (match config - (($ <guix-configuration> guix build-group build-accounts - authorize-key? keys - use-substitutes? substitute-urls - max-silent-time timeout - extra-options - log-file http-proxy tmpdir) - (list (shepherd-service - (documentation "Run the Guix daemon.") - (provision '(guix-daemon)) - (requirement '(user-processes)) - (start - #~(make-forkexec-constructor - (list #$(file-append guix "/bin/guix-daemon") + (match-record config <guix-configuration> + (guix build-group build-accounts authorize-key? authorized-keys + use-substitutes? substitute-urls max-silent-time timeout + log-compression extra-options log-file http-proxy tmpdir + chroot-directories) + (list (shepherd-service + (documentation "Run the Guix daemon.") + (provision '(guix-daemon)) + (requirement '(user-processes)) + (modules '((srfi srfi-1))) + (start + #~(make-forkexec-constructor + (cons* #$(file-append guix "/bin/guix-daemon") "--build-users-group" #$build-group "--max-silent-time" #$(number->string max-silent-time) "--timeout" #$(number->string timeout) + "--log-compression" #$(symbol->string log-compression) #$@(if use-substitutes? '() '("--no-substitutes")) "--substitute-urls" #$(string-join substitute-urls) - #$@extra-options) - - #:environment-variables - (list #$@(if http-proxy - (list (string-append "http_proxy=" http-proxy)) - '()) - #$@(if tmpdir - (list (string-append "TMPDIR=" tmpdir)) - '())) - - #:log-file #$log-file)) - (stop #~(make-kill-destructor))))))) + #$@extra-options + + ;; Add CHROOT-DIRECTORIES and all their dependencies (if + ;; these are store items) to the chroot. + (append-map (lambda (file) + (append-map (lambda (directory) + (list "--chroot-directory" + directory)) + (call-with-input-file file + read))) + '#$(map references-file chroot-directories))) + + #:environment-variables + (list #$@(if http-proxy + (list (string-append "http_proxy=" http-proxy)) + '()) + #$@(if tmpdir + (list (string-append "TMPDIR=" tmpdir)) + '())) + + #:log-file #$log-file)) + (stop #~(make-kill-destructor)))))) (define (guix-accounts config) "Return the user accounts and user groups for CONFIG." @@ -1514,6 +1528,24 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) #$@(map (cut hydra-key-authorization <> guix) keys)) #~#f)))) +(define* (references-file item #:optional (name "references")) + "Return a file that contains the list of references of ITEM." + (if (struct? item) ;lowerable object + (computed-file name + (with-imported-modules (source-module-closure + '((guix build store-copy))) + #~(begin + (use-modules (guix build store-copy)) + + (call-with-output-file #$output + (lambda (port) + (write (call-with-input-file "graph" + read-reference-graph) + port))))) + #:options `(#:local-build? #f + #:references-graphs (("graph" ,item)))) + (plain-file name "()"))) + (define guix-service-type (service-type (name 'guix) @@ -1523,6 +1555,16 @@ failed to register hydra.gnu.org public key: ~a~%" status)))))))) (service-extension activation-service-type guix-activation) (service-extension profile-service-type (compose list guix-configuration-guix)))) + + ;; Extensions can specify extra directories to add to the build chroot. + (compose concatenate) + (extend (lambda (config directories) + (guix-configuration + (inherit config) + (chroot-directories + (append (guix-configuration-chroot-directories config) + directories))))) + (default-value (guix-configuration)) (description "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}."))) diff --git a/gnu/services/monitoring.scm b/gnu/services/monitoring.scm new file mode 100644 index 0000000000..49a65db4b5 --- /dev/null +++ b/gnu/services/monitoring.scm @@ -0,0 +1,91 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Sou Bunnbu <iyzsong@member.fsf.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 services monitoring) + #:use-module (gnu services) + #:use-module (gnu services shepherd) + #:use-module (gnu packages admin) + #:use-module (gnu packages monitoring) + #:use-module (gnu system shadow) + #:use-module (guix gexp) + #:use-module (guix records) + #:use-module (ice-9 match) + #:export (darkstat-configuration + darkstat-service-type)) + + +;;; +;;; darkstat +;;; + +(define-record-type* <darkstat-configuration> + darkstat-configuration make-darkstat-configuration darkstat-configuration? + (package darkstat-configuration-package + (default darkstat)) + (interface darkstat-configuration-interface) + (port darkstat-configuration-port + (default "667")) + (bind-address darkstat-configuration-bind-address + (default "127.0.0.1")) + (base darkstat-configuration-base + (default "/"))) + +(define %darkstat-accounts + (list (user-account + (name "darkstat") + (group "darkstat") + (system? #t) + (comment "darkstat daemon user") + (home-directory "/var/lib/darkstat") + (shell (file-append shadow "/sbin/nologin"))) + (user-group + (name "darkstat") + (system? #t)))) + +(define darkstat-shepherd-service + (match-lambda + (($ <darkstat-configuration> + package interface port bind-address base) + (shepherd-service + (documentation "Network statistics gatherer.") + (provision '(darkstat)) + (requirement '(networking)) + (start #~(make-forkexec-constructor + (list #$(file-append package "/sbin/darkstat") + "-i" #$interface + "-p" #$port + "-b" #$bind-address + "--base" #$base + "--syslog" "--no-daemon" + "--chroot" "/var/lib/darkstat" + "--user" "darkstat" + "--import" "darkstat.db" + "--export" "darkstat.db"))) + (stop #~(make-kill-destructor)))))) + +(define darkstat-service-type + (service-type + (name 'darkstat) + (description + "Run @command{darkstat} to serve network traffic statictics reports over +HTTP.") + (extensions + (list (service-extension account-service-type + (const %darkstat-accounts)) + (service-extension shepherd-root-service-type + (compose list darkstat-shepherd-service)))))) diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm index 845cdb07ba..bf71e7f26a 100644 --- a/gnu/services/virtualization.scm +++ b/gnu/services/virtualization.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ryan Moe <ryan.moe@gmail.com> +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,16 +24,29 @@ #:use-module (gnu services dbus) #:use-module (gnu services shepherd) #:use-module (gnu system shadow) + #:use-module (gnu system file-systems) #:use-module (gnu packages admin) #:use-module (gnu packages virtualization) #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix packages) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (libvirt-configuration libvirt-service-type - virtlog-service-type)) + virtlog-service-type + + %qemu-platforms + lookup-qemu-platforms + qemu-platform? + qemu-platform-name + + qemu-binfmt-configuration + qemu-binfmt-configuration? + qemu-binfmt-service-type)) (define (uglify-field-name field-name) (let ((str (symbol->string field-name))) @@ -490,3 +504,254 @@ potential infinite waits blocking libvirt.")) (generate-documentation `((libvirt-configuration ,libvirt-configuration-fields)) 'libvirt-configuration)) + + +;;; +;;; Transparent QEMU emulation via binfmt_misc. +;;; + +;; Platforms that QEMU can emulate. +(define-record-type <qemu-platform> + (qemu-platform name family magic mask) + qemu-platform? + (name qemu-platform-name) ;string + (family qemu-platform-family) ;string + (magic qemu-platform-magic) ;bytevector + (mask qemu-platform-mask)) ;bytevector + +(define-syntax bv + (lambda (s) + "Expand the given string into a bytevector." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + (let ((bv (u8-list->bytevector + (map char->integer + (string->list (syntax->datum #'str)))))) + bv))))) + +;;; The platform descriptions below are taken from +;;; 'scripts/qemu-binfmt-conf.sh' in QEMU. + +(define %i386 + (qemu-platform "i386" "i386" + (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x03\x00") + (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + +(define %i486 + (qemu-platform "i486" "i386" + (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x06\x00") + (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + +(define %alpha + (qemu-platform "alpha" "alpha" + (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x26\x90") + (bv "\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + +(define %arm + (qemu-platform "arm" "arm" + (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28\x00") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + +(define %armeb + (qemu-platform "armeb" "arm" + (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x28") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %sparc + (qemu-platform "sparc" "sparc" + (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x02") + (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %sparc32plus + (qemu-platform "sparc32plus" "sparc" + (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x12") + (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %ppc + (qemu-platform "ppc" "ppc" + (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x14") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %ppc64 + (qemu-platform "ppc64" "ppc" + (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %ppc64le + (qemu-platform "ppc64le" "ppcle" + (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x15\x00") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\x00"))) + +(define %m68k + (qemu-platform "m68k" "m68k" + (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x04") + (bv "\xff\xff\xff\xff\xff\xff\xfe\xfe\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +;; XXX: We could use the other endianness on a MIPS host. +(define %mips + (qemu-platform "mips" "mips" + (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %mipsel + (qemu-platform "mipsel" "mips" + (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + +(define %mipsn32 + (qemu-platform "mipsn32" "mips" + (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %mipsn32el + (qemu-platform "mipsn32el" "mips" + (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + +(define %mips64 + (qemu-platform "mips64" "mips" + (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %mips64el + (qemu-platform "mips64el" "mips" + (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x08\x00") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + +(define %sh4 + (qemu-platform "sh4" "sh4" + (bv "\x7fELF\x01\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a\x00") + (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + +(define %sh4eb + (qemu-platform "sh4eb" "sh4" + (bv "\x7fELF\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x2a") + (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %s390x + (qemu-platform "s390x" "s390x" + (bv "\x7fELF\x02\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x16") + (bv "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %aarch64 + (qemu-platform "aarch64" "arm" + (bv "\x7fELF\x02\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\xb7\x00") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff\xff"))) + +(define %hppa + (qemu-platform "hppa" "hppa" + (bv "\x7f\x45\x4c\x46\x01\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x0f") + (bv "\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\xff\xff"))) + +(define %qemu-platforms + (list %i386 %i486 %alpha %arm %sparc32plus %ppc %ppc64 %ppc64le %m68k + %mips %mipsel %mipsn32 %mipsn32el %mips64 %mips64el + %sh4 %sh4eb %s390x %aarch64 %hppa)) + +(define (lookup-qemu-platforms . names) + "Return the list of QEMU platforms that match NAMES--a list of names such as +\"arm\", \"hppa\", etc." + (filter (lambda (platform) + (member (qemu-platform-name platform) names)) + %qemu-platforms)) + +(define-record-type* <qemu-binfmt-configuration> + qemu-binfmt-configuration make-qemu-binfmt-configuration + qemu-binfmt-configuration? + (qemu qemu-binfmt-configuration-qemu + (default qemu)) + (platforms qemu-binfmt-configuration-platforms + (default '())) ;safest default + (guix-support? qemu-binfmt-configuration-guix-support? + (default #f))) + +(define (qemu-platform->binfmt qemu platform) + "Return a gexp that evaluates to a binfmt string for PLATFORM, using the +given QEMU package." + (define (bytevector->binfmt-string bv) + ;; Return a binfmt-friendly string representing BV. Hex-encode every + ;; character, in particular because the doc notes "that you must escape + ;; any NUL bytes; parsing halts at the first one". + (string-concatenate + (map (lambda (n) + (string-append "\\x" + (string-pad (number->string n 16) 2 #\0))) + (bytevector->u8-list bv)))) + + (match platform + (($ <qemu-platform> name family magic mask) + ;; See 'Documentation/binfmt_misc.txt' in the kernel. + #~(string-append ":qemu-" #$name ":M::" + #$(bytevector->binfmt-string magic) + ":" #$(bytevector->binfmt-string mask) + ":" #$(file-append qemu "/bin/qemu-" name) + ":" ;FLAGS go here + )))) + +(define %binfmt-mount-point + (file-system-mount-point %binary-format-file-system)) + +(define %binfmt-register-file + (string-append %binfmt-mount-point "/register")) + +(define qemu-binfmt-shepherd-services + (match-lambda + (($ <qemu-binfmt-configuration> qemu platforms) + (list (shepherd-service + (provision '(qemu-binfmt)) + (documentation "Install binfmt_misc handlers for QEMU.") + (requirement '(file-system-/proc/sys/fs/binfmt_misc)) + (start #~(lambda () + ;; Register the handlers for all of PLATFORMS. + (for-each (lambda (str) + (call-with-output-file + #$%binfmt-register-file + (lambda (port) + (display str port)))) + (list + #$@(map (cut qemu-platform->binfmt qemu + <>) + platforms))) + #t)) + (stop #~(lambda (_) + ;; Unregister the handlers. + (for-each (lambda (name) + (let ((file (string-append + #$%binfmt-mount-point + "/qemu-" name))) + (call-with-output-file file + (lambda (port) + (display "-1" port))))) + '#$(map qemu-platform-name platforms)) + #f))))))) + +(define qemu-binfmt-guix-chroot + (match-lambda + ;; Add QEMU and its dependencies to the guix-daemon chroot so that our + ;; binfmt_misc handlers work in the chroot (otherwise 'execve' would fail + ;; with ENOENT.) + ;; + ;; The 'F' flag of binfmt_misc is meant to address this problem by loading + ;; the interpreter upfront rather than lazily, but apparently that is + ;; insufficient (perhaps it loads the 'qemu-ARCH' binary upfront but looks + ;; up its dependencies lazily?). + (($ <qemu-binfmt-configuration> qemu platforms guix?) + (if guix? (list qemu) '())))) + +(define qemu-binfmt-service-type + ;; TODO: Make a separate binfmt_misc service out of this? + (service-type (name 'qemu-binfmt) + (extensions + (list (service-extension file-system-service-type + (const + (list %binary-format-file-system))) + (service-extension shepherd-root-service-type + qemu-binfmt-shepherd-services) + (service-extension guix-service-type + qemu-binfmt-guix-chroot))) + (default-value (qemu-binfmt-configuration)) + (description + "This service supports transparent emulation of binaries +compiled for other architectures using QEMU and the @code{binfmt_misc} +functionality of the kernel Linux."))) |