diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/local.mk | 1 | ||||
| -rw-r--r-- | gnu/services/admin.scm | 174 | ||||
| -rw-r--r-- | gnu/services/web.scm | 172 | ||||
| -rw-r--r-- | gnu/tests/admin.scm | 127 | ||||
| -rw-r--r-- | gnu/tests/web.scm | 99 |
5 files changed, 270 insertions, 303 deletions
diff --git a/gnu/local.mk b/gnu/local.mk index 374e25165e..bc01a3cd36 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -529,7 +529,6 @@ GNU_SYSTEM_MODULES = \ %D%/build/vm.scm \ \ %D%/tests.scm \ - %D%/tests/admin.scm \ %D%/tests/audio.scm \ %D%/tests/base.scm \ %D%/tests/databases.scm \ diff --git a/gnu/services/admin.scm b/gnu/services/admin.scm index aaf0b904fd..f08c896334 100644 --- a/gnu/services/admin.scm +++ b/gnu/services/admin.scm @@ -20,19 +20,14 @@ (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 @@ -46,29 +41,7 @@ rottlog-configuration rottlog-configuration? rottlog-service - 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-file-http-auth - tailon-configuration-file-users - - <tailon-configuration> - tailon-configuration - tailon-configuration? - tailon-configuration-config-file - tailon-configuration-package - - tailon-service-type)) + rottlog-service-type)) ;;; Commentary: ;;; @@ -203,149 +176,4 @@ Old log files are removed or compressed according to the configuration.") 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)) - (wrap-lines tailon-configuration-file-wrap-lines - (default #t)) - (http-auth tailon-configuration-file-http-auth - (default #f)) - (users tailon-configuration-file-users - (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? - wrap-lines http-auth users) - (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 ", ") - "]")) - ("debug" . ,(if debug? "true" #f)) - ("wrap-lines" . ,(if wrap-lines "true" "false")) - ("http-auth" . ,http-auth) - ("users" . ,(if users - (string-concatenate - (cons "\n" - (map (match-lambda - ((user . pass) - (string-append - " " user ":" pass))) - users))) - #f))))))))) - -(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) - (description - "Run Tailon, a Web application for monitoring, viewing, and searching log -files.") - (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/services/web.scm b/gnu/services/web.scm index df82a6de61..16e77f8243 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2017 nee <nee-git@hidamari.blue> ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr> +;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,9 +33,11 @@ #:use-module (gnu packages web) #:use-module (gnu packages php) #:use-module (gnu packages guile) + #:use-module (gnu packages logging) #:use-module (guix records) #:use-module (guix modules) #:use-module (guix gexp) + #:use-module ((guix store) #:select (text-file)) #:use-module ((guix utils) #:select (version-major)) #:use-module ((guix packages) #:select (package-version)) #:use-module (srfi srfi-1) @@ -164,7 +167,29 @@ hpcguix-web-configuration hpcguix-web-configuration? - hpcguix-web-service-type)) + hpcguix-web-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-file-http-auth + tailon-configuration-file-users + + <tailon-configuration> + tailon-configuration + tailon-configuration? + tailon-configuration-config-file + tailon-configuration-package + + tailon-service-type)) ;;; Commentary: ;;; @@ -980,3 +1005,148 @@ a webserver.") (const %hpcguix-web-activation)) (service-extension shepherd-root-service-type (compose list hpcguix-web-shepherd-service)))))) + + +;;; +;;; 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)) + (wrap-lines tailon-configuration-file-wrap-lines + (default #t)) + (http-auth tailon-configuration-file-http-auth + (default #f)) + (users tailon-configuration-file-users + (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? + wrap-lines http-auth users) + (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 ", ") + "]")) + ("debug" . ,(if debug? "true" #f)) + ("wrap-lines" . ,(if wrap-lines "true" "false")) + ("http-auth" . ,http-auth) + ("users" . ,(if users + (string-concatenate + (cons "\n" + (map (match-lambda + ((user . pass) + (string-append + " " user ":" pass))) + users))) + #f))))))))) + +(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) + (description + "Run Tailon, a Web application for monitoring, viewing, and searching log +files.") + (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)))) diff --git a/gnu/tests/admin.scm b/gnu/tests/admin.scm deleted file mode 100644 index a5abbe9ad4..0000000000 --- a/gnu/tests/admin.scm +++ /dev/null @@ -1,127 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> -;;; Copyright © 2018 Clément Lassieur <clement@lassieur.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 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-assert "service running" - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'tailon)) - 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)))) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 73d502dd0e..45fcb668fb 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -33,7 +33,8 @@ #:export (%test-httpd %test-nginx %test-php-fpm - %test-hpcguix-web)) + %test-hpcguix-web + %test-tailon)) (define %index.html-contents ;; Contents of the /index.html file. @@ -359,3 +360,99 @@ HTTP-PORT, along with php-fpm." (name "hpcguix-web") (description "Connect to a running hpcguix-web server.") (value (run-hpcguix-web-server-test name %hpcguix-web-os)))) + + +(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-assert "service running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'tailon)) + 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)))) |