diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/local.mk | 1 | ||||
| -rw-r--r-- | gnu/services/admin.scm | 151 | ||||
| -rw-r--r-- | gnu/tests/admin.scm | 128 |
3 files changed, 279 insertions, 1 deletions
diff --git a/gnu/local.mk b/gnu/local.mk index 724c6b6758..29dee73c46 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -478,6 +478,7 @@ GNU_SYSTEM_MODULES = \ %D%/build/vm.scm \ \ %D%/tests.scm \ + %D%/tests/admin.scm \ %D%/tests/base.scm \ %D%/tests/dict.scm \ %D%/tests/nfs.scm \ diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm index b9e3fa70a4..1044833fef 100644 --- a/gnu/services/admin.scm +++ b/gnu/services/admin.scm @@ -20,14 +20,19 @@ (define-module (gnu services admin) #:use-module (gnu packages admin) #:use-module (gnu packages base) + #:use-module (gnu packages logging) #:use-module (gnu services) #:use-module (gnu services mcron) #:use-module (gnu services shepherd) + #:use-module (gnu services web) + #:use-module (gnu system shadow) #:use-module (guix gexp) + #:use-module (guix store) #:use-module (guix packages) #:use-module (guix records) #:use-module (srfi srfi-1) #:use-module (ice-9 vlist) + #:use-module (ice-9 match) #:export (%default-rotations %rotated-files @@ -41,7 +46,27 @@ rottlog-configuration rottlog-configuration? rottlog-service - rottlog-service-type)) + rottlog-service-type + + <tailon-configuration-file> + tailon-configuration-file + tailon-configuration-file? + tailon-configuration-file-files + tailon-configuration-file-bind + tailon-configuration-file-relative-root + tailon-configuration-file-allow-transfers? + tailon-configuration-file-follow-names? + tailon-configuration-file-tail-lines + tailon-configuration-file-allowed-commands + tailon-configuration-file-debug? + + <tailon-configuration> + tailon-configuration + tailon-configuration? + tailon-configuration-config-file + tailon-configuration-package + + tailon-service-type)) ;;; Commentary: ;;; @@ -172,4 +197,128 @@ for ROTATION." rotations))))) (default-value (rottlog-configuration)))) + +;;; +;;; Tailon +;;; + +(define-record-type* <tailon-configuration-file> + tailon-configuration-file make-tailon-configuration-file + tailon-configuration-file? + (files tailon-configuration-file-files + (default '("/var/log"))) + (bind tailon-configuration-file-bind + (default "localhost:8080")) + (relative-root tailon-configuration-file-relative-root + (default #f)) + (allow-transfers? tailon-configuration-file-allow-transfers? + (default #t)) + (follow-names? tailon-configuration-file-follow-names? + (default #t)) + (tail-lines tailon-configuration-file-tail-lines + (default 200)) + (allowed-commands tailon-configuration-file-allowed-commands + (default '("tail" "grep" "awk"))) + (debug? tailon-configuration-file-debug? + (default #f))) + +(define (tailon-configuration-files-string files) + (string-append + "\n" + (string-join + (map + (lambda (x) + (string-append + " - " + (cond + ((string? x) + (simple-format #f "'~A'" x)) + ((list? x) + (string-join + (cons (simple-format #f "'~A':" (car x)) + (map + (lambda (x) (simple-format #f " - '~A'" x)) + (cdr x))) + "\n")) + (else (error x))))) + files) + "\n"))) + +(define-gexp-compiler (tailon-configuration-file-compiler + (file <tailon-configuration-file>) system target) + (match file + (($ <tailon-configuration-file> files bind relative-root + allow-transfers? follow-names? + tail-lines allowed-commands debug?) + (text-file + "tailon-config.yaml" + (string-concatenate + (filter-map + (match-lambda + ((key . #f) #f) + ((key . value) (string-append key ": " value "\n"))) + + `(("files" . ,(tailon-configuration-files-string files)) + ("bind" . ,bind) + ("relative-root" . ,relative-root) + ("allow-transfers" . ,(if allow-transfers? "true" "false")) + ("follow-names" . ,(if follow-names? "true" "false")) + ("tail-lines" . ,(number->string tail-lines)) + ("commands" . ,(string-append "[" + (string-join allowed-commands ", ") + "]")) + ,@(if debug? '(("debug" . "true")) '())))))))) + +(define-record-type* <tailon-configuration> + tailon-configuration make-tailon-configuration + tailon-configuration? + (config-file tailon-configuration-config-file + (default (tailon-configuration-file))) + (package tailon-configuration-package + (default tailon))) + +(define tailon-shepherd-service + (match-lambda + (($ <tailon-configuration> config-file package) + (list (shepherd-service + (provision '(tailon)) + (documentation "Run the tailon daemon.") + (start #~(make-forkexec-constructor + `(,(string-append #$package "/bin/tailon") + "-c" ,#$config-file) + #:user "tailon" + #:group "tailon")) + (stop #~(make-kill-destructor))))))) + +(define %tailon-accounts + (list (user-group (name "tailon") (system? #t)) + (user-account + (name "tailon") + (group "tailon") + (system? #t) + (comment "tailon") + (home-directory "/var/empty") + (shell (file-append shadow "/sbin/nologin"))))) + +(define tailon-service-type + (service-type + (name 'tailon) + (extensions + (list (service-extension shepherd-root-service-type + tailon-shepherd-service) + (service-extension account-service-type + (const %tailon-accounts)))) + (compose concatenate) + (extend (lambda (parameter files) + (tailon-configuration + (inherit parameter) + (config-file + (let ((old-config-file + (tailon-configuration-config-file parameter))) + (tailon-configuration-file + (inherit old-config-file) + (files (append (tailon-configuration-file-files old-config-file) + files)))))))) + (default-value (tailon-configuration)))) + ;;; admin.scm ends here diff --git a/gnu/tests/admin.scm b/gnu/tests/admin.scm new file mode 100644 index 0000000000..3c7deb5426 --- /dev/null +++ b/gnu/tests/admin.scm @@ -0,0 +1,128 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> +;;; +;;; 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 tests admin) + #:use-module (gnu tests) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system shadow) + #:use-module (gnu system vm) + #:use-module (gnu services) + #:use-module (gnu services admin) + #:use-module (gnu services networking) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:export (%test-tailon)) + +(define %tailon-os + ;; Operating system under test. + (simple-operating-system + (dhcp-client-service) + (service tailon-service-type + (tailon-configuration + (config-file + (tailon-configuration-file + (bind "0.0.0.0:8080"))))))) + +(define* (run-tailon-test #:optional (http-port 8081)) + "Run tests in %TAILON-OS, which has tailon running and listening on +HTTP-PORT." + (define os + (marionette-operating-system + %tailon-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((,http-port . 8080))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (ice-9 match) + (gnu build marionette) + (web uri) + (web client) + (web response)) + + (define marionette + ;; Forward the guest's HTTP-PORT, where tailon is listening, to + ;; port 8080 in the host. + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "tailon") + + (test-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'tailon) + 'running!) + marionette)) + + (define* (retry-on-error f #:key times delay) + (let loop ((attempt 1)) + (match (catch + #t + (lambda () + (cons #t + (f))) + (lambda args + (cons #f + args))) + ((#t . return-value) + return-value) + ((#f . error-args) + (if (>= attempt times) + error-args + (begin + (sleep delay) + (loop (+ 1 attempt)))))))) + + (test-equal "http-get" + 200 + (retry-on-error + (lambda () + (let-values (((response text) + (http-get #$(format + #f + "http://localhost:~A/" + http-port) + #:decode-body? #t))) + (response-code response))) + #:times 10 + #:delay 5)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "tailon-test" test)) + +(define %test-tailon + (system-test + (name "tailon") + (description "Connect to a running Tailon server.") + (value (run-tailon-test)))) |