From 5dfd80e1c5c9803a281804801592d191cf9148ae Mon Sep 17 00:00:00 2001 From: Chris Marusich Date: Sun, 22 Jul 2018 16:23:53 -0700 Subject: services: tor: Add a system test. * gnu/services/networking.scm (tor-configuration->torrc): Set PidFile to /var/run/tor/tor.pid in the base torrc configuration. (tor-shepherd-service) : Call make-forkexec-constructor/container with a new #:pid-file argument to tell Shepherd where to find the PID file. Add a a new to its existing #:mappings argument to share /var/run/tor with the the container. (tor-hidden-services-activation): Update docstring. Create /var/run/tor and set its permissions so only the tor user can access it. * gnu/tests/networking.scm (%test-tor, %tor-os): New variables. (run-tor-test): New procedure. --- gnu/tests/networking.scm | 56 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 55 insertions(+), 1 deletion(-) (limited to 'gnu/tests') diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm index 323679e7fc..5e54edc462 100644 --- a/gnu/tests/networking.scm +++ b/gnu/tests/networking.scm @@ -30,7 +30,7 @@ #:use-module (gnu packages bash) #:use-module (gnu packages networking) #:use-module (gnu services shepherd) - #:export (%test-inetd %test-openvswitch %test-dhcpd)) + #:export (%test-inetd %test-openvswitch %test-dhcpd %test-tor)) (define %inetd-os ;; Operating system with 2 inetd services. @@ -339,3 +339,57 @@ subnet 192.168.1.0 netmask 255.255.255.0 { (name "dhcpd") (description "Test a running DHCP daemon configuration.") (value (run-dhcpd-test)))) + + +;;; +;;; Services related to Tor +;;; + +(define %tor-os + (simple-operating-system + (tor-service))) + +(define (run-tor-test) + (define os + (marionette-operating-system %tor-os + #:imported-modules '((gnu services herd)) + #:requirements '(tor))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (ice-9 popen) + (ice-9 rdelim) + (srfi srfi-64)) + + (define marionette + (make-marionette (list #$(virtual-machine os)))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "tor") + + (test-assert "tor is alive" + (marionette-eval + '(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + (live-service-running + (find (lambda (live) + (memq 'tor + (live-service-provision live))) + (current-services)))) + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "tor-test" test)) + +(define %test-tor + (system-test + (name "tor") + (description "Test a running Tor daemon configuration.") + (value (run-tor-test)))) -- cgit v1.2.3 From b0f951e4f04766892933e3b60d1b24ab3a8589c2 Mon Sep 17 00:00:00 2001 From: Chris Marusich Date: Mon, 30 Jul 2018 22:53:47 -0700 Subject: tests: tor: Add more test cases. * gnu/tests/networking.scm (%tor-os/unix-socks-socket): New variable. (run-tor-test) : New variables. <"tor is alive">: Move common code from this test case... : ...into this new procedure. <"tor is listening", "tor is alive, even when using a SOCKS socket"> <"tor is listening, even when using a SOCKS socket">: New test cases. --- gnu/tests/networking.scm | 59 +++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 53 insertions(+), 6 deletions(-) (limited to 'gnu/tests') diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm index 5e54edc462..7ca71f0c2c 100644 --- a/gnu/tests/networking.scm +++ b/gnu/tests/networking.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Thomas Danckaert ;;; Copyright © 2017 Marius Bakke +;;; Copyright © 2018 Chris Marusich ;;; ;;; This file is part of GNU Guix. ;;; @@ -349,12 +350,29 @@ subnet 192.168.1.0 netmask 255.255.255.0 { (simple-operating-system (tor-service))) +(define %tor-os/unix-socks-socket + (simple-operating-system + (service tor-service-type + (tor-configuration + (config-file + (plain-file "test-torrc" + "\ +SocksPort unix:/var/run/tor/socks-sock +UnixSocksGroupWritable 1 +") + ))))) + (define (run-tor-test) (define os (marionette-operating-system %tor-os #:imported-modules '((gnu services herd)) #:requirements '(tor))) + (define os/unix-socks-socket + (marionette-operating-system %tor-os/unix-socks-socket + #:imported-modules '((gnu services herd)) + #:requirements '(tor))) + (define test (with-imported-modules '((gnu build marionette)) #~(begin @@ -366,12 +384,7 @@ subnet 192.168.1.0 netmask 255.255.255.0 { (define marionette (make-marionette (list #$(virtual-machine os)))) - (mkdir #$output) - (chdir #$output) - - (test-begin "tor") - - (test-assert "tor is alive" + (define (tor-is-alive? marionette) (marionette-eval '(begin (use-modules (gnu services herd) @@ -383,6 +396,40 @@ subnet 192.168.1.0 netmask 255.255.255.0 { (current-services)))) marionette)) + (mkdir #$output) + (chdir #$output) + + (test-begin "tor") + + ;; Test the usual Tor service. + + (test-assert "tor is alive" + (tor-is-alive? marionette)) + + (test-assert "tor is listening" + (let ((default-port 9050)) + (wait-for-tcp-port default-port marionette))) + + ;; Don't run two VMs at once. + (marionette-control "quit" marionette) + + ;; Test the Tor service using a SOCKS socket. + + (let* ((socket-directory "/tmp/more-sockets") + (_ (mkdir socket-directory)) + (marionette/unix-socks-socket + (make-marionette + (list #$(virtual-machine os/unix-socks-socket)) + ;; We can't use the same socket directory as the first + ;; marionette. + #:socket-directory socket-directory))) + (test-assert "tor is alive, even when using a SOCKS socket" + (tor-is-alive? marionette/unix-socks-socket)) + + (test-assert "tor is listening, even when using a SOCKS socket" + (wait-for-unix-socket "/var/run/tor/socks-sock" + marionette/unix-socks-socket))) + (test-end) (exit (= (test-runner-fail-count (test-runner-current)) 0))))) -- cgit v1.2.3 From 3bcb305b98e02f6c9d98e7325813fc00f18f0e6c Mon Sep 17 00:00:00 2001 From: Chris Marusich Date: Tue, 31 Jul 2018 01:13:48 -0700 Subject: services: tor: Make it easier to use UNIX sockets. * doc/guix.texi (Networking Services): Document it, and mention that tor-service is deprecated. * gnu/services/networking.scm () : New field. (tor-configuration->torrc): When socks-socket-type is 'unix, set SocksPort to UNIX domain socket /var/run/tor/socks-sock and set UnixSocksGroupWritable to 1. * gnu/tests/networking.scm (%tor-os/unix-socks-socket): Instead of using a custom config file, just set socks-socket-type to 'unix. --- doc/guix.texi | 55 +++++++++++++++++++++++++++++++++++++++------ gnu/services/networking.scm | 10 +++++++-- gnu/tests/networking.scm | 8 +------ 3 files changed, 57 insertions(+), 16 deletions(-) (limited to 'gnu/tests') diff --git a/doc/guix.texi b/doc/guix.texi index d2d278df47..3a3368b78f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11450,16 +11450,57 @@ detailed discussion of each configuration field. @end deftp @cindex Tor -@deffn {Scheme Procedure} tor-service [@var{config-file}] [#:tor @var{tor}] -Return a service to run the @uref{https://torproject.org, Tor} anonymous -networking daemon. +@defvr {Scheme Variable} tor-service-type +This is the type for a service that runs the @uref{https://torproject.org, +Tor} anonymous networking daemon. The service is configured using a +@code{} record. By default, the Tor daemon runs as the +@code{tor} unprivileged user, which is a member of the @code{tor} group. + +@end defvr -The daemon runs as the @code{tor} unprivileged user. It is passed -@var{config-file}, a file-like object, with an additional @code{User tor} line -and lines for hidden services added via @code{tor-hidden-service}. Run -@command{man tor} for information about the configuration file. +@deffn {Scheme Procedure} tor-service [@var{config-file}] [#:tor @var{tor}] +This procedure is deprecated and will be removed in a future release. Return +a service of the @code{tor-service-type} type. @var{config-file} and +@var{tor} have the same meaning as in @code{}. @end deffn +@deftp {Data Type} tor-configuration +@table @asis +@item @code{tor} (default: @code{tor}) +The package that provides the Tor daemon. This package is expected to provide +the daemon at @file{bin/tor} relative to its output directory. The default +package is the @uref{https://www.torproject.org, Tor Project's} +implementation. + +@item @code{config-file} (default: @code{(plain-file "empty" "")}) +The configuration file to use. It will be appended to a default configuration +file, and the final configuration file will be passed to @code{tor} via its +@code{-f} option. This may be any ``file-like'' object (@pxref{G-Expressions, +file-like objects}). See @code{man tor} for details on the configuration file +syntax. + +@item @code{hidden-services} (default: @code{'()}) +The list of @code{} records to use. For any hidden service +you include in this list, appropriate configuration to enable the hidden +service will be automatically added to the default configuration file. You +may conveniently create @code{} records using the +@code{tor-hidden-service} procedure described below. + +@item @code{socks-socket-type} (default: @code{'tcp}) +The default socket type that Tor should use for its SOCKS socket. This must +be either @code{'tcp} or @code{'unix}. If it is @code{'tcp}, then by default +Tor will listen on TCP port 9050 on the loopback interface (i.e., localhost). +If it is @code{'unix}, then Tor will listen on the UNIX domain socket +@file{/var/run/tor/socks-sock}, which will be made writable by members of the +@code{tor} group. + +If you want to customize the SOCKS socket in more detail, leave +@code{socks-socket-type} at its default value of @code{'tcp} and use +@code{config-file} to override the default by providing your own +@code{SocksPort} option. +@end table +@end deftp + @cindex hidden service @deffn {Scheme Procedure} tor-hidden-service @var{name} @var{mapping} Define a new Tor @dfn{hidden service} called @var{name} and implementing diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index b7f2bfe7b3..b6b5ee3fec 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -577,7 +577,9 @@ demand."))) (config-file tor-configuration-config-file (default (plain-file "empty" ""))) (hidden-services tor-configuration-hidden-services - (default '()))) + (default '())) + (socks-socket-type tor-configuration-socks-socket-type ; 'tcp or 'unix + (default 'tcp))) (define %tor-accounts ;; User account and groups for Tor. @@ -599,7 +601,7 @@ demand."))) (define (tor-configuration->torrc config) "Return a 'torrc' file for CONFIG." (match config - (($ tor config-file services) + (($ tor config-file services socks-socket-type) (computed-file "torrc" (with-imported-modules '((guix build utils)) @@ -615,6 +617,10 @@ User tor DataDirectory /var/lib/tor PidFile /var/run/tor/tor.pid Log notice syslog\n" port) + (when (eq? 'unix '#$socks-socket-type) + (display "\ +SocksPort unix:/var/run/tor/socks-sock +UnixSocksGroupWritable 1\n" port)) (for-each (match-lambda ((service (ports hosts) ...) diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm index 7ca71f0c2c..381c5caf14 100644 --- a/gnu/tests/networking.scm +++ b/gnu/tests/networking.scm @@ -354,13 +354,7 @@ subnet 192.168.1.0 netmask 255.255.255.0 { (simple-operating-system (service tor-service-type (tor-configuration - (config-file - (plain-file "test-torrc" - "\ -SocksPort unix:/var/run/tor/socks-sock -UnixSocksGroupWritable 1 -") - ))))) + (socks-socket-type 'unix))))) (define (run-tor-test) (define os -- cgit v1.2.3 From 4ab6a2f23d43f6c7e4a5a7420db613c5ba5b03b6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 8 Sep 2018 22:59:04 +0200 Subject: tests: base: Add Guile-Gcrypt & co. to the search path. Fixes a regression introduced in ca719424455465fca4b872c371daf2a46de88b33, whereby (gcrypt hash) would not be found in the system under test, leading to a failure of the "/run/current-system is a GC root" test. * gnu/tests/base.scm (run-basic-test)[guix&co]: New variable. [test]: Add all of GUIX&CO to %LOAD-PATH. --- gnu/tests/base.scm | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) (limited to 'gnu/tests') diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index f27064af85..f97581de33 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -42,6 +42,7 @@ #:use-module (guix monads) #:use-module (guix packages) #:use-module (srfi srfi-1) + #:use-module (ice-9 match) #:export (run-basic-test %test-basic-os %test-halt @@ -68,6 +69,11 @@ initialization step, such as entering a LUKS passphrase." (fold-services (operating-system-services os) #:target-type special-files-service-type))) + (define guix&co + (match (package-transitive-propagated-inputs guix) + (((labels packages) ...) + (cons guix packages)))) + (define test (with-imported-modules '((gnu build marionette) (guix build syscalls)) @@ -345,8 +351,14 @@ info --version") 'success! (marionette-eval '(begin ;; Make sure the (guix …) modules are found. - (add-to-load-path - #+(file-append guix "/share/guile/site/2.2")) + (eval-when (expand load eval) + (set! %load-path + (append (map (lambda (package) + (string-append package + "/share/guile/site/" + (effective-version))) + '#$guix&co) + %load-path))) (use-modules (srfi srfi-34) (guix store)) -- cgit v1.2.3 From 19de8273eefceac1ba6ddc8d7e374a13f57c678b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 7 Sep 2018 22:29:40 +0200 Subject: services: tailon: Move to (gnu services web). This allows (gnu services admin) to remain deeper in the module graph and to be used by (gnu services web). * gnu/services/admin.scm () (tailon-configuration-files-string) (tailon-configuration-file-compiler, ) (tailon-shepherd-service, %tailon-accounts) (tailon-service-type): Move to... * gnu/services/web.scm: ... here. * gnu/tests/admin.scm: Remove. Move test to... * gnu/tests/web.scm (%tailon-os) (run-tailon-test, %test-tailon): ... here. --- gnu/local.mk | 1 - gnu/services/admin.scm | 174 +------------------------------------------------ gnu/services/web.scm | 172 +++++++++++++++++++++++++++++++++++++++++++++++- gnu/tests/admin.scm | 127 ------------------------------------ gnu/tests/web.scm | 99 +++++++++++++++++++++++++++- 5 files changed, 270 insertions(+), 303 deletions(-) delete mode 100644 gnu/tests/admin.scm (limited to 'gnu/tests') 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-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-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 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 ) system target) - (match 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 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 - (($ 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 ;;; Copyright © 2017, 2018 Clément Lassieur ;;; Copyright © 2018 Pierre-Antoine Rouby +;;; Copyright © 2017 Christopher Baines ;;; ;;; 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-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-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 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 ) system target) + (match 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 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 + (($ 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 -;;; Copyright © 2018 Clément Lassieur -;;; -;;; 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 . - -(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)))) -- cgit v1.2.3 From 9926b8f8096a0198cc34585bf7424eba0c98aee2 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Fri, 17 Aug 2018 16:39:07 +0530 Subject: gnu: services: Add iptables service. * gnu/services/networking.scm (): New record type. (iptables-service-type): New variable. * gnu/tests/networking.scm (run-iptables-test): New procedure. (%test-iptables): New variable. * doc/guix.texi (Networking Services): Document it. --- doc/guix.texi | 48 +++++++++++++++++ gnu/services/networking.scm | 56 ++++++++++++++++++- gnu/tests/networking.scm | 129 +++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 231 insertions(+), 2 deletions(-) (limited to 'gnu/tests') diff --git a/doc/guix.texi b/doc/guix.texi index 8987b20fa9..b925485be5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11612,6 +11612,54 @@ Thus, it can be instantiated like this: @end lisp @end defvr +@cindex iptables +@defvr {Scheme Variable} iptables-service-type +This is the service type to set up an iptables configuration. iptables is a +packet filtering framework supported by the Linux kernel. This service +supports configuring iptables for both IPv4 and IPv6. A simple example +configuration rejecting all incoming connections except those to the ssh port +22 is shown below. + +@lisp +(service iptables-service-type + (iptables-configuration + (ipv4-rules (plain-file "iptables.rules" "*filter +:INPUT ACCEPT +:FORWARD ACCEPT +:OUTPUT ACCEPT +-A INPUT -p tcp --dport 22 -j ACCEPT +-A INPUT -j REJECT --reject-with icmp-port-unreachable +COMMIT +")) + (ipv6-rules (plain-file "ip6tables.rules" "*filter +:INPUT ACCEPT +:FORWARD ACCEPT +:OUTPUT ACCEPT +-A INPUT -p tcp --dport 22 -j ACCEPT +-A INPUT -j REJECT --reject-with icmp6-port-unreachable +COMMIT +")))) +@end lisp +@end defvr + +@deftp {Data Type} iptables-configuration +The data type representing the configuration of iptables. + +@table @asis +@item @code{iptables} (default: @code{iptables}) +The iptables package that provides @code{iptables-restore} and +@code{ip6tables-restore}. +@item @code{ipv4-rules} (default: @code{%iptables-accept-all-rules}) +The iptables rules to use. It will be passed to @code{iptables-restore}. +This may be any ``file-like'' object (@pxref{G-Expressions, file-like +objects}). +@item @code{ipv6-rules} (default: @code{%iptables-accept-all-rules}) +The ip6tables rules to use. It will be passed to @code{ip6tables-restore}. +This may be any ``file-like'' object (@pxref{G-Expressions, file-like +objects}). +@end table +@end deftp + @cindex NTP @cindex real time clock @deffn {Scheme Procedure} ntp-service [#:ntp @var{ntp}] @ diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index b6b5ee3fec..bd1d5a2706 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Marius Bakke ;;; Copyright © 2018 Tobias Geerinckx-Rice ;;; Copyright © 2018 Chris Marusich +;;; Copyright © 2018 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -103,7 +104,14 @@ wpa-supplicant-service-type openvswitch-service-type - openvswitch-configuration)) + openvswitch-configuration + + iptables-configuration + iptables-configuration? + iptables-configuration-iptables + iptables-configuration-ipv4-rules + iptables-configuration-ipv6-rules + iptables-service-type)) ;;; Commentary: ;;; @@ -1108,4 +1116,50 @@ networking.")))) switch designed to enable massive network automation through programmatic extension."))) +;;; +;;; iptables +;;; + +(define %iptables-accept-all-rules + (plain-file "iptables-accept-all.rules" + "*filter +:INPUT ACCEPT +:FORWARD ACCEPT +:OUTPUT ACCEPT +COMMIT +")) + +(define-record-type* + iptables-configuration make-iptables-configuration iptables-configuration? + (iptables iptables-configuration-iptables + (default iptables)) + (ipv4-rules iptables-configuration-ipv4-rules + (default %iptables-accept-all-rules)) + (ipv6-rules iptables-configuration-ipv6-rules + (default %iptables-accept-all-rules))) + +(define iptables-shepherd-service + (match-lambda + (($ iptables ipv4-rules ipv6-rules) + (let ((iptables-restore (file-append iptables "/sbin/iptables-restore")) + (ip6tables-restore (file-append iptables "/sbin/ip6tables-restore"))) + (shepherd-service + (documentation "Packet filtering framework") + (provision '(iptables)) + (start #~(lambda _ + (invoke #$iptables-restore #$ipv4-rules) + (invoke #$ip6tables-restore #$ipv6-rules))) + (stop #~(lambda _ + (invoke #$iptables-restore #$%iptables-accept-all-rules) + (invoke #$ip6tables-restore #$%iptables-accept-all-rules)))))))) + +(define iptables-service-type + (service-type + (name 'iptables) + (description + "Run @command{iptables-restore}, setting up the specified rules.") + (extensions + (list (service-extension shepherd-root-service-type + (compose list iptables-shepherd-service)))))) + ;;; networking.scm ends here diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm index 381c5caf14..ceba7f7d5d 100644 --- a/gnu/tests/networking.scm +++ b/gnu/tests/networking.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017 Thomas Danckaert ;;; Copyright © 2017 Marius Bakke ;;; Copyright © 2018 Chris Marusich +;;; Copyright © 2018 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,9 +30,11 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (gnu packages bash) + #:use-module (gnu packages linux) #:use-module (gnu packages networking) #:use-module (gnu services shepherd) - #:export (%test-inetd %test-openvswitch %test-dhcpd %test-tor)) + #:use-module (ice-9 match) + #:export (%test-inetd %test-openvswitch %test-dhcpd %test-tor %test-iptables)) (define %inetd-os ;; Operating system with 2 inetd services. @@ -434,3 +437,127 @@ subnet 192.168.1.0 netmask 255.255.255.0 { (name "tor") (description "Test a running Tor daemon configuration.") (value (run-tor-test)))) + +(define* (run-iptables-test) + "Run tests of 'iptables-service-type'." + (define iptables-rules + "*filter +:INPUT ACCEPT +:FORWARD ACCEPT +:OUTPUT ACCEPT +-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp-port-unreachable +COMMIT +") + + (define ip6tables-rules + "*filter +:INPUT ACCEPT +:FORWARD ACCEPT +:OUTPUT ACCEPT +-A INPUT -p tcp -m tcp --dport 7 -j REJECT --reject-with icmp6-port-unreachable +COMMIT +") + + (define inetd-echo-port 7) + + (define os + (marionette-operating-system + (simple-operating-system + (dhcp-client-service) + (service inetd-service-type + (inetd-configuration + (entries (list + (inetd-entry + (name "echo") + (socket-type 'stream) + (protocol "tcp") + (wait? #f) + (user "root")))))) + (service iptables-service-type + (iptables-configuration + (ipv4-rules (plain-file "iptables.rules" iptables-rules)) + (ipv6-rules (plain-file "ip6tables.rules" ip6tables-rules))))) + #:imported-modules '((gnu services herd)) + #:requirements '(inetd iptables))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-64) + (gnu build marionette)) + (define marionette + (make-marionette (list #$(virtual-machine os)))) + + (define (dump-iptables iptables-save marionette) + (marionette-eval + `(begin + (use-modules (ice-9 popen) + (ice-9 rdelim) + (ice-9 regex)) + (call-with-output-string + (lambda (out) + (call-with-port + (open-pipe* OPEN_READ ,iptables-save) + (lambda (in) + (let loop ((line (read-line in))) + ;; iptables-save does not output rules in the exact + ;; same format we loaded using iptables-restore. It + ;; adds comments, packet counters, etc. We remove + ;; these additions. + (unless (eof-object? line) + (cond + ;; Remove comments + ((string-match "^#" line) #t) + ;; Remove packet counters + ((string-match "^:([A-Z]*) ([A-Z]*) .*" line) + => (lambda (match-record) + (format out ":~a ~a~%" + (match:substring match-record 1) + (match:substring match-record 2)))) + ;; Pass other lines without modification + (else (display line out) + (newline out))) + (loop (read-line in))))))))) + marionette)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "iptables") + + (test-equal "iptables-save dumps the same rules that were loaded" + (dump-iptables #$(file-append iptables "/sbin/iptables-save") + marionette) + #$iptables-rules) + + (test-equal "ip6tables-save dumps the same rules that were loaded" + (dump-iptables #$(file-append iptables "/sbin/ip6tables-save") + marionette) + #$ip6tables-rules) + + (test-error "iptables firewall blocks access to inetd echo service" + 'misc-error + (wait-for-tcp-port inetd-echo-port marionette #:timeout 5)) + + ;; TODO: This test freezes up at the login prompt without any + ;; relevant messages on the console. Perhaps it is waiting for some + ;; timeout. Find and fix this issue. + ;; (test-assert "inetd echo service is accessible after iptables firewall is stopped" + ;; (begin + ;; (marionette-eval + ;; '(begin + ;; (use-modules (gnu services herd)) + ;; (stop-service 'iptables)) + ;; marionette) + ;; (wait-for-tcp-port inetd-echo-port marionette #:timeout 5))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "iptables" test)) + +(define %test-iptables + (system-test + (name "iptables") + (description "Test a running iptables daemon.") + (value (run-iptables-test)))) -- cgit v1.2.3 From 3b97a1779f3b65d582b8edc8c154b6414314b946 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sun, 26 Aug 2018 23:33:48 +0200 Subject: services: Add Varnish service. * gnu/services/web.scm (): New record type. (%varnish-accounts, %varnish-service-type): New variables. (varnish-shepherd-service): New procedure. * gnu/tests/web.scm (%varnish-vcl, %varnish-os): New variables. (%test-varnish): New test. * doc/guix.texi (Web Services): Document it. --- doc/guix.texi | 80 +++++++++++++++++++++++++++++++++++++++++++ gnu/services/web.scm | 96 +++++++++++++++++++++++++++++++++++++++++++++++++++- gnu/tests/web.scm | 41 ++++++++++++++++++++++ 3 files changed, 216 insertions(+), 1 deletion(-) (limited to 'gnu/tests') diff --git a/doc/guix.texi b/doc/guix.texi index 76ec718b07..6b4b06f46d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -16888,6 +16888,86 @@ body of a named location block cannot contain location blocks. @end table @end deftp +@subsubheading Varnish Cache +@cindex Varnish +Varnish is a fast cache server that sits in between web applications +and end users. It proxies requests from clients and caches the +accessed URLs such that multiple requests for the same resource only +creates one request to the back-end. + +@defvr {Scheme Variable} varnish-service-type +Service type for the Varnish daemon. +@end defvr + +@deftp {Data Type} varnish-configuration +Data type representing the @code{varnish} service configuration. +This type has the following parameters: + +@table @asis +@item @code{package} (default: @code{varnish}) +The Varnish package to use. + +@item @code{name} (default: @code{"default"}) +A name for this Varnish instance. Varnish will create a directory in +@file{/var/varnish/} with this name and keep temporary files there. If +the name starts with a forward slash, it is interpreted as an absolute +directory name. + +Pass the @code{-n} argument to other Varnish programs to connect to the +named instance, e.g. @command{varnishncsa -n default}. + +@item @code{backend} (default: @code{"localhost:8080"}) +The backend to use. This option has no effect if @code{vcl} is set. + +@item @code{vcl} (default: #f) +The @dfn{VCL} (Varnish Configuration Language) program to run. If this +is @code{#f}, Varnish will proxy @code{backend} using the default +configuration. Otherwise this must be a file-like object with valid +VCL syntax. + +@c Varnish does not support HTTPS, so keep this URL to avoid confusion. +For example, to mirror @url{http://www.gnu.org,www.gnu.org} with VCL you +can do something along these lines: + +@example +(define %gnu-mirror + (plain-file + "gnu.vcl" + "vcl 4.1; +backend gnu @{ .host = "www.gnu.org"; @}")) + +(operating-system + ... + (services (cons (service varnish-service-type + (varnish-configuration + (listen '(":80")) + (vcl %gnu-mirror))) + %base-services))) +@end example + +The configuration of an already running Varnish instance can be inspected +and changed using the @command{varnishadm} program. + +Consult the @url{https://varnish-cache.org/docs/,Varnish User Guide} and +@url{https://book.varnish-software.com/4.0/,Varnish Book} for +comprehensive documentation on Varnish and its configuration language. + +@item @code{listen} (default: @code{'("localhost:80")}) +List of addresses Varnish will listen on. + +@item @code{storage} (default: @code{'("malloc,128m")}) +List of storage backends that will be available in VCL. + +@item @code{parameters} (default: @code{'()}) +List of run-time parameters in the form @code{'(("parameter" . "value"))}. + +@item @code{extra-options} (default: @code{'()}) +Additional arguments to pass to the @command{varnishd} process. + +@end table +@end deftp + +@subsubheading FastCGI @cindex fastcgi @cindex fcgiwrap FastCGI is an interface between the front-end and the back-end of a web diff --git a/gnu/services/web.scm b/gnu/services/web.scm index 1c38e7d8d3..1edb1f4d34 100644 --- a/gnu/services/web.scm +++ b/gnu/services/web.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017, 2018 Clément Lassieur ;;; Copyright © 2018 Pierre-Antoine Rouby ;;; Copyright © 2017 Christopher Baines +;;; Copyright © 2018 Marius Bakke ;;; ;;; This file is part of GNU Guix. ;;; @@ -190,7 +191,21 @@ tailon-configuration-config-file tailon-configuration-package - tailon-service-type)) + tailon-service-type + + + varnish-configuration + varnish-configuration? + varnish-configuration-package + varnish-configuration-name + varnish-configuration-backend + varnish-configuration-vcl + varnish-configuration-listen + varnish-configuration-storage + varnish-configuration-parameters + varnish-configuration-extra-options + + varnish-service-type)) ;;; Commentary: ;;; @@ -1162,3 +1177,82 @@ files.") (files (append (tailon-configuration-file-files old-config-file) files)))))))) (default-value (tailon-configuration)))) + + +;;; +;;; Varnish +;;; + +(define-record-type* + varnish-configuration make-varnish-configuration + varnish-configuration? + (package varnish-configuration-package ; + (default varnish)) + (name varnish-configuration-name ;string + (default "default")) + (backend varnish-configuration-backend ;string + (default "localhost:8080")) + (vcl varnish-configuration-vcl ;#f | + (default #f)) + (listen varnish-configuration-listen ;list of strings + (default '("localhost:80"))) + (storage varnish-configuration-storage ;list of strings + (default '("malloc,128m"))) + (parameters varnish-configuration-parameters ;list of string pairs + (default '())) + (extra-options varnish-configuration-extra-options ;list of strings + (default '()))) + +(define %varnish-accounts + (list (user-group + (name "varnish") + (system? #t)) + (user-account + (name "varnish") + (group "varnish") + (system? #t) + (comment "Varnish Cache User") + (home-directory "/var/varnish") + (shell (file-append shadow "/sbin/nologin"))))) + +(define varnish-shepherd-service + (match-lambda + (($ package name backend vcl listen storage + parameters extra-options) + (list (shepherd-service + (provision (list (symbol-append 'varnish- (string->symbol name)))) + (documentation (string-append "The Varnish Web Accelerator" + " (" name ")")) + (requirement '(networking)) + (start #~(make-forkexec-constructor + (list #$(file-append package "/sbin/varnishd") + "-n" #$name + #$@(if vcl + #~("-f" #$vcl) + #~("-b" #$backend)) + #$@(append-map (lambda (a) (list "-a" a)) listen) + #$@(append-map (lambda (s) (list "-s" s)) storage) + #$@(append-map (lambda (p) + (list "-p" (format #f "~a=~a" + (car p) (cdr p)))) + parameters) + #$@extra-options) + ;; Varnish will drop privileges to the "varnish" user when + ;; it exists. Not passing #:user here allows the service + ;; to bind to ports < 1024. + #:pid-file (if (string-prefix? "/" #$name) + (string-append #$name "/_.pid") + (string-append "/var/varnish/" #$name "/_.pid")))) + (stop #~(make-kill-destructor))))))) + +(define varnish-service-type + (service-type + (name 'varnish) + (description "Run the Varnish cache server.") + (extensions + (list (service-extension account-service-type + (const %varnish-accounts)) + (service-extension shepherd-root-service-type + varnish-shepherd-service))) + (default-value + (varnish-configuration)))) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 45fcb668fb..bcc919137b 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -32,6 +32,7 @@ #:use-module (guix store) #:export (%test-httpd %test-nginx + %test-varnish %test-php-fpm %test-hpcguix-web %test-tailon)) @@ -167,6 +168,46 @@ HTTP-PORT." (value (run-webserver-test name %nginx-os #:log-file "/var/log/nginx/access.log")))) + +;;; +;;; Varnish +;;; + +(define %varnish-vcl + (mixed-text-file + "varnish-test.vcl" + "vcl 4.0; +backend dummy { .host = \"127.1.1.1\"; } +sub vcl_recv { return(synth(200, \"OK\")); } +sub vcl_synth { + synthetic(\"" %index.html-contents "\"); + set resp.http.Content-Type = \"text/plain\"; + return(deliver); +}")) + +(define %varnish-os + (simple-operating-system + (dhcp-client-service) + ;; Pretend to be a web server that serves %index.html-contents. + (service varnish-service-type + (varnish-configuration + (name "/tmp/server") + ;; Use a small VSL buffer to fit in the test VM. + (parameters '(("vsl_space" . "4M"))) + (vcl %varnish-vcl))) + ;; Proxy the "server" using the builtin configuration. + (service varnish-service-type + (varnish-configuration + (parameters '(("vsl_space" . "4M"))) + (backend "localhost:80") + (listen '(":8080")))))) + +(define %test-varnish + (system-test + (name "varnish") + (description "Test the Varnish Cache server.") + (value (run-webserver-test "varnish-default" %varnish-os)))) + ;;; ;;; PHP-FPM -- cgit v1.2.3 From 4353981eb095459c47a9e12950745ac0304162ae Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Wed, 26 Sep 2018 01:45:05 +0200 Subject: tests: Add missing copyright statement. This is a follow-up to commit 3b97a1779f3b65d582b8edc8c154b6414314b946. * gnu/tests/web.scm: Update copyright header. --- gnu/tests/web.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'gnu/tests') diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index bcc919137b..2e209fee97 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017 Christopher Baines ;;; Copyright © 2017, 2018 Clément Lassieur ;;; Copyright © 2018 Pierre-Antoine Rouby +;;; Copyright © 2018 Marius Bakke ;;; ;;; This file is part of GNU Guix. ;;; -- cgit v1.2.3 From 258a6d944ed891fa92fa87a16731e5dfe0bac477 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 13 Jul 2018 20:39:46 +0100 Subject: services: Add Gitolite. * gnu/services/version-control.scm (, ): New record types. (gitolite-accounts, gitolite-activation): New procedures. (gitolite-service-type): New variables. * gnu/tests/version-control.scm (%gitolite-test-admin-keypair, %gitolite-os, %test-gitolite): New variables. (run-gitolite-test): New procedure. * doc/guix.texi (Version Control): Document the gitolite service. --- doc/guix.texi | 94 ++++++++++++++++++++ gnu/services/version-control.scm | 179 ++++++++++++++++++++++++++++++++++++++- gnu/tests/version-control.scm | 114 ++++++++++++++++++++++++- 3 files changed, 385 insertions(+), 2 deletions(-) (limited to 'gnu/tests') diff --git a/doc/guix.texi b/doc/guix.texi index e1046eb512..94bb0ec4e1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -21028,6 +21028,100 @@ could instantiate a cgit service like this: (cgitrc ""))) @end example +@subsubheading Gitolite Service + +@cindex Gitolite service +@cindex Git, hosting +@uref{http://gitolite.com/gitolite/, Gitolite} is a tool for hosting Git +repositories on a central server. + +Gitolite can handle multiple repositories and users, and supports flexible +configuration of the permissions for the users on the repositories. + +The following example will configure Gitolite using the default @code{git} +user, and the provided SSH public key. + +@example +(service gitolite-service-type + (gitolite-configuration + (admin-pubkey (plain-file + "yourname.pub" + "ssh-rsa AAAA... guix@@example.com")))) +@end example + +Gitolite is configured through a special admin repository which you can clone, +for example, if you setup Gitolite on @code{example.com}, you would run the +following command to clone the admin repository. + +@example +git clone git@@example.com:gitolite-admin +@end example + +When the Gitolite service is activated, the provided @code{admin-pubkey} will +be inserted in to the @file{keydir} directory in the gitolite-admin +repository. If this results in a change in the repository, it will be +committed using the message ``gitolite setup by GNU Guix''. + +@deftp {Data Type} gitolite-configuration +Data type representing the configuration for @code{gitolite-service-type}. + +@table @asis +@item @code{package} (default: @var{gitolite}) +Gitolite package to use. + +@item @code{user} (default: @var{git}) +User to use for Gitolite. This will be user that you use when accessing +Gitolite over SSH. + +@item @code{group} (default: @var{git}) +Group to use for Gitolite. + +@item @code{home-directory} (default: @var{"/var/lib/gitolite"}) +Directory in which to store the Gitolite configuration and repositories. + +@item @code{rc-file} (default: @var{(gitolite-rc-file)}) +A ``file-like'' object (@pxref{G-Expressions, file-like objects}), +representing the configuration for Gitolite. + +@item @code{admin-pubkey} (default: @var{#f}) +A ``file-like'' object (@pxref{G-Expressions, file-like objects}) used to +setup Gitolite. This will be inserted in to the @file{keydir} directory +within the gitolite-admin repository. + +To specify the SSH key as a string, use the @code{plain-file} function. + +@example +(plain-file "yourname.pub" "ssh-rsa AAAA... guix@@example.com") +@end example + +@end table +@end deftp + +@deftp {Data Type} gitolite-rc-file +Data type representing the Gitolite RC file. + +@table @asis +@item @code{umask} (default: @code{#o0077}) +This controls the permissions Gitolite sets on the repositories and their +contents. + +A value like @code{#o0027} will give read access to the group used by Gitolite +(by default: @code{git}). This is necessary when using Gitolite with software +like cgit or gitweb. + +@item @code{git-config-keys} (default: @code{""}) +Gitolite allows you to set git config values using the "config" keyword. This +setting allows control over the config keys to accept. + +@item @code{roles} (default: @code{'(("READERS" . 1) ("WRITERS" . ))}) +Set the role names allowed to be used by users running the perms command. + +@item @code{enable} (default: @code{'("help" "desc" "info" "perms" "writable" "ssh-authkeys" "git-config" "daemon" "gitweb")}) +This setting controls the commands and features to enable within Gitolite. + +@end table +@end deftp + @node Game Services @subsubsection Game Services diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm index 58274c8bee..cc8cd22021 100644 --- a/gnu/services/version-control.scm +++ b/gnu/services/version-control.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Sou Bunnbu ;;; Copyright © 2017 Oleg Pykhalov ;;; Copyright © 2017 Clément Lassieur +;;; Copyright © 2018 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,7 +41,23 @@ git-http-configuration git-http-configuration? - git-http-nginx-location-configuration)) + git-http-nginx-location-configuration + + + gitolite-configuration + gitolite-configuration-package + gitolite-configuration-user + gitolite-configuration-rc-file + gitolite-configuration-admin-pubkey + + + gitolite-rc-file + gitolite-rc-file-umask + gitolite-rc-file-git-config-keys + gitolite-rc-file-roles + gitolite-rc-file-enable + + gitolite-service-type)) ;;; Commentary: ;;; @@ -197,3 +214,163 @@ access to exported repositories under @file{/srv/git}." "") (list "fastcgi_param GIT_PROJECT_ROOT " git-root ";") "fastcgi_param PATH_INFO $1;")))))) + + +;;; +;;; Gitolite +;;; + +(define-record-type* + gitolite-rc-file make-gitolite-rc-file + gitolite-rc-file? + (umask gitolite-rc-file-umask + (default #o0077)) + (git-config-keys gitolite-rc-file-git-config-keys + (default "")) + (roles gitolite-rc-file-roles + (default '(("READERS" . 1) + ("WRITERS" . 1)))) + (enable gitolite-rc-file-enable + (default '("help" + "desc" + "info" + "perms" + "writable" + "ssh-authkeys" + "git-config" + "daemon" + "gitweb")))) + +(define-gexp-compiler (gitolite-rc-file-compiler + (file ) system target) + (match file + (($ umask git-config-keys roles enable) + (apply text-file* "gitolite.rc" + `("%RC = (\n" + " UMASK => " ,(format #f "~4,'0o" umask) ",\n" + " GIT_CONFIG_KEYS => '" ,git-config-keys "',\n" + " ROLES => {\n" + ,@(map (match-lambda + ((role . value) + (simple-format #f " ~A => ~A,\n" role value))) + roles) + " },\n" + "\n" + " ENABLE => [\n" + ,@(map (lambda (value) + (simple-format #f " '~A',\n" value)) + enable) + " ],\n" + ");\n" + "\n" + "1;\n"))))) + +(define-record-type* + gitolite-configuration make-gitolite-configuration + gitolite-configuration? + (package gitolite-configuration-package + (default gitolite)) + (user gitolite-configuration-user + (default "git")) + (group gitolite-configuration-group + (default "git")) + (home-directory gitolite-configuration-home-directory + (default "/var/lib/gitolite")) + (rc-file gitolite-configuration-rc-file + (default (gitolite-rc-file))) + (admin-pubkey gitolite-configuration-admin-pubkey)) + +(define gitolite-accounts + (match-lambda + (($ package user group home-directory + rc-file admin-pubkey) + ;; User group and account to run Gitolite. + (list (user-group (name user) (system? #t)) + (user-account + (name user) + (group group) + (system? #t) + (comment "Gitolite user") + (home-directory home-directory)))))) + +(define gitolite-activation + (match-lambda + (($ package user group home + rc-file admin-pubkey) + #~(begin + (use-modules (ice-9 match) + (guix build utils)) + + (let* ((user-info (getpwnam #$user)) + (admin-pubkey #$admin-pubkey) + (pubkey-file (string-append + #$home "/" + (basename + (strip-store-file-name admin-pubkey))))) + + (simple-format #t "guix: gitolite: installing ~A\n" #$rc-file) + (copy-file #$rc-file #$(string-append home "/.gitolite.rc")) + + ;; The key must be writable, so copy it from the store + (copy-file admin-pubkey pubkey-file) + + (chmod pubkey-file #o500) + (chown pubkey-file + (passwd:uid user-info) + (passwd:gid user-info)) + + ;; Set the git configuration, to avoid gitolite trying to use + ;; the hostname command, as the network might not be up yet + (with-output-to-file #$(string-append home "/.gitconfig") + (lambda () + (display "[user] + name = GNU Guix + email = guix@localhost +"))) + ;; Run Gitolite setup, as this updates the hooks and include the + ;; admin pubkey if specified. The admin pubkey is required for + ;; initial setup, and will replace the previous key if run after + ;; initial setup + (match (primitive-fork) + (0 + ;; Exit with a non-zero status code if an exception is thrown. + (dynamic-wind + (const #t) + (lambda () + (setenv "HOME" (passwd:dir user-info)) + (setenv "USER" #$user) + (setgid (passwd:gid user-info)) + (setuid (passwd:uid user-info)) + (primitive-exit + (system* #$(file-append package "/bin/gitolite") + "setup" + "-m" "gitolite setup by GNU Guix" + "-pk" pubkey-file))) + (lambda () + (primitive-exit 1)))) + (pid (waitpid pid))) + + (when (file-exists? pubkey-file) + (delete-file pubkey-file))))))) + +(define gitolite-service-type + (service-type + (name 'gitolite) + (extensions + (list (service-extension activation-service-type + gitolite-activation) + (service-extension account-service-type + gitolite-accounts) + (service-extension profile-service-type + ;; The Gitolite package in Guix uses + ;; gitolite-shell in the authorized_keys file, so + ;; gitolite-shell needs to be on the PATH for + ;; gitolite to work. + (lambda (config) + (list + (gitolite-configuration-package config)))))) + (description + "Setup @command{gitolite}, a Git hosting tool providing access over SSH.. +By default, the @code{git} user is used, but this is configurable. +Additionally, Gitolite can integrate with with tools like gitweb or cgit to +provide a web interface to view selected repositories."))) diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm index 3b935a1b48..4409b8a12b 100644 --- a/gnu/tests/version-control.scm +++ b/gnu/tests/version-control.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017, 2018 Oleg Pykhalov ;;; Copyright © 2017, 2018 Ludovic Courtès ;;; Copyright © 2017, 2018 Clément Lassieur +;;; Copyright © 2018 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,14 +28,17 @@ #:use-module (gnu services) #:use-module (gnu services version-control) #:use-module (gnu services cgit) + #:use-module (gnu services ssh) #:use-module (gnu services web) #:use-module (gnu services networking) #:use-module (gnu packages version-control) + #:use-module (gnu packages ssh) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix modules) #:export (%test-cgit - %test-git-http)) + %test-git-http + %test-gitolite)) (define README-contents "Hello! This is what goes inside the 'README' file.") @@ -300,3 +304,111 @@ HTTP-PORT." (name "git-http") (description "Connect to a running Git HTTP server.") (value (run-git-http-test)))) + + +;;; +;;; Gitolite. +;;; + +(define %gitolite-test-admin-keypair + (computed-file + "gitolite-test-admin-keypair" + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (ice-9 match) (srfi srfi-26) + (guix build utils)) + + (mkdir #$output) + (invoke #$(file-append openssh "/bin/ssh-keygen") + "-f" (string-append #$output "/test-admin") + "-t" "rsa" + "-q" + "-N" ""))))) + +(define %gitolite-os + (simple-operating-system + (dhcp-client-service) + (service openssh-service-type) + (service gitolite-service-type + (gitolite-configuration + (admin-pubkey + (file-append %gitolite-test-admin-keypair "/test-admin.pub")))))) + +(define (run-gitolite-test) + (define os + (marionette-operating-system + %gitolite-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((2222 . 22))))) + + (define test + (with-imported-modules '((gnu build marionette) + (guix build utils)) + #~(begin + (use-modules (srfi srfi-64) + (rnrs io ports) + (gnu build marionette) + (guix build utils)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "gitolite") + + ;; Wait for sshd to be up and running. + (test-assert "service running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'ssh-daemon)) + marionette)) + + (display #$%gitolite-test-admin-keypair) + + (setenv "GIT_SSH_VARIANT" "ssh") + (setenv "GIT_SSH_COMMAND" + (string-join + '(#$(file-append openssh "/bin/ssh") + "-i" #$(file-append %gitolite-test-admin-keypair + "/test-admin") + "-o" "UserKnownHostsFile=/dev/null" + "-o" "StrictHostKeyChecking=no"))) + + (test-assert "cloning the admin repository" + (invoke #$(file-append git "/bin/git") + "clone" "-v" + "ssh://git@localhost:2222/gitolite-admin" + "/tmp/clone")) + + (test-assert "admin key exists" + (file-exists? "/tmp/clone/keydir/test-admin.pub")) + + (with-directory-excursion "/tmp/clone" + (invoke #$(file-append git "/bin/git") + "-c" "user.name=Guix" "-c" "user.email=guix" + "commit" + "-m" "Test commit" + "--allow-empty") + + (test-assert "pushing, and the associated hooks" + (invoke #$(file-append git "/bin/git") "push"))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "gitolite" test)) + +(define %test-gitolite + (system-test + (name "gitolite") + (description "Clone the Gitolite admin repository.") + (value (run-gitolite-test)))) -- cgit v1.2.3 From 17bea1803cf706d8db053d8d73302a4455684d29 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 29 Sep 2018 21:18:45 -0400 Subject: Revert "services: Add Gitolite." This reverts commit 258a6d944ed891fa92fa87a16731e5dfe0bac477. --- doc/guix.texi | 94 -------------------- gnu/services/version-control.scm | 179 +-------------------------------------- gnu/tests/version-control.scm | 114 +------------------------ 3 files changed, 2 insertions(+), 385 deletions(-) (limited to 'gnu/tests') diff --git a/doc/guix.texi b/doc/guix.texi index 94bb0ec4e1..e1046eb512 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -21028,100 +21028,6 @@ could instantiate a cgit service like this: (cgitrc ""))) @end example -@subsubheading Gitolite Service - -@cindex Gitolite service -@cindex Git, hosting -@uref{http://gitolite.com/gitolite/, Gitolite} is a tool for hosting Git -repositories on a central server. - -Gitolite can handle multiple repositories and users, and supports flexible -configuration of the permissions for the users on the repositories. - -The following example will configure Gitolite using the default @code{git} -user, and the provided SSH public key. - -@example -(service gitolite-service-type - (gitolite-configuration - (admin-pubkey (plain-file - "yourname.pub" - "ssh-rsa AAAA... guix@@example.com")))) -@end example - -Gitolite is configured through a special admin repository which you can clone, -for example, if you setup Gitolite on @code{example.com}, you would run the -following command to clone the admin repository. - -@example -git clone git@@example.com:gitolite-admin -@end example - -When the Gitolite service is activated, the provided @code{admin-pubkey} will -be inserted in to the @file{keydir} directory in the gitolite-admin -repository. If this results in a change in the repository, it will be -committed using the message ``gitolite setup by GNU Guix''. - -@deftp {Data Type} gitolite-configuration -Data type representing the configuration for @code{gitolite-service-type}. - -@table @asis -@item @code{package} (default: @var{gitolite}) -Gitolite package to use. - -@item @code{user} (default: @var{git}) -User to use for Gitolite. This will be user that you use when accessing -Gitolite over SSH. - -@item @code{group} (default: @var{git}) -Group to use for Gitolite. - -@item @code{home-directory} (default: @var{"/var/lib/gitolite"}) -Directory in which to store the Gitolite configuration and repositories. - -@item @code{rc-file} (default: @var{(gitolite-rc-file)}) -A ``file-like'' object (@pxref{G-Expressions, file-like objects}), -representing the configuration for Gitolite. - -@item @code{admin-pubkey} (default: @var{#f}) -A ``file-like'' object (@pxref{G-Expressions, file-like objects}) used to -setup Gitolite. This will be inserted in to the @file{keydir} directory -within the gitolite-admin repository. - -To specify the SSH key as a string, use the @code{plain-file} function. - -@example -(plain-file "yourname.pub" "ssh-rsa AAAA... guix@@example.com") -@end example - -@end table -@end deftp - -@deftp {Data Type} gitolite-rc-file -Data type representing the Gitolite RC file. - -@table @asis -@item @code{umask} (default: @code{#o0077}) -This controls the permissions Gitolite sets on the repositories and their -contents. - -A value like @code{#o0027} will give read access to the group used by Gitolite -(by default: @code{git}). This is necessary when using Gitolite with software -like cgit or gitweb. - -@item @code{git-config-keys} (default: @code{""}) -Gitolite allows you to set git config values using the "config" keyword. This -setting allows control over the config keys to accept. - -@item @code{roles} (default: @code{'(("READERS" . 1) ("WRITERS" . ))}) -Set the role names allowed to be used by users running the perms command. - -@item @code{enable} (default: @code{'("help" "desc" "info" "perms" "writable" "ssh-authkeys" "git-config" "daemon" "gitweb")}) -This setting controls the commands and features to enable within Gitolite. - -@end table -@end deftp - @node Game Services @subsubsection Game Services diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm index cc8cd22021..58274c8bee 100644 --- a/gnu/services/version-control.scm +++ b/gnu/services/version-control.scm @@ -3,7 +3,6 @@ ;;; Copyright © 2016 Sou Bunnbu ;;; Copyright © 2017 Oleg Pykhalov ;;; Copyright © 2017 Clément Lassieur -;;; Copyright © 2018 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,23 +40,7 @@ git-http-configuration git-http-configuration? - git-http-nginx-location-configuration - - - gitolite-configuration - gitolite-configuration-package - gitolite-configuration-user - gitolite-configuration-rc-file - gitolite-configuration-admin-pubkey - - - gitolite-rc-file - gitolite-rc-file-umask - gitolite-rc-file-git-config-keys - gitolite-rc-file-roles - gitolite-rc-file-enable - - gitolite-service-type)) + git-http-nginx-location-configuration)) ;;; Commentary: ;;; @@ -214,163 +197,3 @@ access to exported repositories under @file{/srv/git}." "") (list "fastcgi_param GIT_PROJECT_ROOT " git-root ";") "fastcgi_param PATH_INFO $1;")))))) - - -;;; -;;; Gitolite -;;; - -(define-record-type* - gitolite-rc-file make-gitolite-rc-file - gitolite-rc-file? - (umask gitolite-rc-file-umask - (default #o0077)) - (git-config-keys gitolite-rc-file-git-config-keys - (default "")) - (roles gitolite-rc-file-roles - (default '(("READERS" . 1) - ("WRITERS" . 1)))) - (enable gitolite-rc-file-enable - (default '("help" - "desc" - "info" - "perms" - "writable" - "ssh-authkeys" - "git-config" - "daemon" - "gitweb")))) - -(define-gexp-compiler (gitolite-rc-file-compiler - (file ) system target) - (match file - (($ umask git-config-keys roles enable) - (apply text-file* "gitolite.rc" - `("%RC = (\n" - " UMASK => " ,(format #f "~4,'0o" umask) ",\n" - " GIT_CONFIG_KEYS => '" ,git-config-keys "',\n" - " ROLES => {\n" - ,@(map (match-lambda - ((role . value) - (simple-format #f " ~A => ~A,\n" role value))) - roles) - " },\n" - "\n" - " ENABLE => [\n" - ,@(map (lambda (value) - (simple-format #f " '~A',\n" value)) - enable) - " ],\n" - ");\n" - "\n" - "1;\n"))))) - -(define-record-type* - gitolite-configuration make-gitolite-configuration - gitolite-configuration? - (package gitolite-configuration-package - (default gitolite)) - (user gitolite-configuration-user - (default "git")) - (group gitolite-configuration-group - (default "git")) - (home-directory gitolite-configuration-home-directory - (default "/var/lib/gitolite")) - (rc-file gitolite-configuration-rc-file - (default (gitolite-rc-file))) - (admin-pubkey gitolite-configuration-admin-pubkey)) - -(define gitolite-accounts - (match-lambda - (($ package user group home-directory - rc-file admin-pubkey) - ;; User group and account to run Gitolite. - (list (user-group (name user) (system? #t)) - (user-account - (name user) - (group group) - (system? #t) - (comment "Gitolite user") - (home-directory home-directory)))))) - -(define gitolite-activation - (match-lambda - (($ package user group home - rc-file admin-pubkey) - #~(begin - (use-modules (ice-9 match) - (guix build utils)) - - (let* ((user-info (getpwnam #$user)) - (admin-pubkey #$admin-pubkey) - (pubkey-file (string-append - #$home "/" - (basename - (strip-store-file-name admin-pubkey))))) - - (simple-format #t "guix: gitolite: installing ~A\n" #$rc-file) - (copy-file #$rc-file #$(string-append home "/.gitolite.rc")) - - ;; The key must be writable, so copy it from the store - (copy-file admin-pubkey pubkey-file) - - (chmod pubkey-file #o500) - (chown pubkey-file - (passwd:uid user-info) - (passwd:gid user-info)) - - ;; Set the git configuration, to avoid gitolite trying to use - ;; the hostname command, as the network might not be up yet - (with-output-to-file #$(string-append home "/.gitconfig") - (lambda () - (display "[user] - name = GNU Guix - email = guix@localhost -"))) - ;; Run Gitolite setup, as this updates the hooks and include the - ;; admin pubkey if specified. The admin pubkey is required for - ;; initial setup, and will replace the previous key if run after - ;; initial setup - (match (primitive-fork) - (0 - ;; Exit with a non-zero status code if an exception is thrown. - (dynamic-wind - (const #t) - (lambda () - (setenv "HOME" (passwd:dir user-info)) - (setenv "USER" #$user) - (setgid (passwd:gid user-info)) - (setuid (passwd:uid user-info)) - (primitive-exit - (system* #$(file-append package "/bin/gitolite") - "setup" - "-m" "gitolite setup by GNU Guix" - "-pk" pubkey-file))) - (lambda () - (primitive-exit 1)))) - (pid (waitpid pid))) - - (when (file-exists? pubkey-file) - (delete-file pubkey-file))))))) - -(define gitolite-service-type - (service-type - (name 'gitolite) - (extensions - (list (service-extension activation-service-type - gitolite-activation) - (service-extension account-service-type - gitolite-accounts) - (service-extension profile-service-type - ;; The Gitolite package in Guix uses - ;; gitolite-shell in the authorized_keys file, so - ;; gitolite-shell needs to be on the PATH for - ;; gitolite to work. - (lambda (config) - (list - (gitolite-configuration-package config)))))) - (description - "Setup @command{gitolite}, a Git hosting tool providing access over SSH.. -By default, the @code{git} user is used, but this is configurable. -Additionally, Gitolite can integrate with with tools like gitweb or cgit to -provide a web interface to view selected repositories."))) diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm index 4409b8a12b..3b935a1b48 100644 --- a/gnu/tests/version-control.scm +++ b/gnu/tests/version-control.scm @@ -2,7 +2,6 @@ ;;; Copyright © 2017, 2018 Oleg Pykhalov ;;; Copyright © 2017, 2018 Ludovic Courtès ;;; Copyright © 2017, 2018 Clément Lassieur -;;; Copyright © 2018 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,17 +27,14 @@ #:use-module (gnu services) #:use-module (gnu services version-control) #:use-module (gnu services cgit) - #:use-module (gnu services ssh) #:use-module (gnu services web) #:use-module (gnu services networking) #:use-module (gnu packages version-control) - #:use-module (gnu packages ssh) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix modules) #:export (%test-cgit - %test-git-http - %test-gitolite)) + %test-git-http)) (define README-contents "Hello! This is what goes inside the 'README' file.") @@ -304,111 +300,3 @@ HTTP-PORT." (name "git-http") (description "Connect to a running Git HTTP server.") (value (run-git-http-test)))) - - -;;; -;;; Gitolite. -;;; - -(define %gitolite-test-admin-keypair - (computed-file - "gitolite-test-admin-keypair" - (with-imported-modules (source-module-closure - '((guix build utils))) - #~(begin - (use-modules (ice-9 match) (srfi srfi-26) - (guix build utils)) - - (mkdir #$output) - (invoke #$(file-append openssh "/bin/ssh-keygen") - "-f" (string-append #$output "/test-admin") - "-t" "rsa" - "-q" - "-N" ""))))) - -(define %gitolite-os - (simple-operating-system - (dhcp-client-service) - (service openssh-service-type) - (service gitolite-service-type - (gitolite-configuration - (admin-pubkey - (file-append %gitolite-test-admin-keypair "/test-admin.pub")))))) - -(define (run-gitolite-test) - (define os - (marionette-operating-system - %gitolite-os - #:imported-modules '((gnu services herd) - (guix combinators)))) - - (define vm - (virtual-machine - (operating-system os) - (port-forwardings `((2222 . 22))))) - - (define test - (with-imported-modules '((gnu build marionette) - (guix build utils)) - #~(begin - (use-modules (srfi srfi-64) - (rnrs io ports) - (gnu build marionette) - (guix build utils)) - - (define marionette - (make-marionette (list #$vm))) - - (mkdir #$output) - (chdir #$output) - - (test-begin "gitolite") - - ;; Wait for sshd to be up and running. - (test-assert "service running" - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'ssh-daemon)) - marionette)) - - (display #$%gitolite-test-admin-keypair) - - (setenv "GIT_SSH_VARIANT" "ssh") - (setenv "GIT_SSH_COMMAND" - (string-join - '(#$(file-append openssh "/bin/ssh") - "-i" #$(file-append %gitolite-test-admin-keypair - "/test-admin") - "-o" "UserKnownHostsFile=/dev/null" - "-o" "StrictHostKeyChecking=no"))) - - (test-assert "cloning the admin repository" - (invoke #$(file-append git "/bin/git") - "clone" "-v" - "ssh://git@localhost:2222/gitolite-admin" - "/tmp/clone")) - - (test-assert "admin key exists" - (file-exists? "/tmp/clone/keydir/test-admin.pub")) - - (with-directory-excursion "/tmp/clone" - (invoke #$(file-append git "/bin/git") - "-c" "user.name=Guix" "-c" "user.email=guix" - "commit" - "-m" "Test commit" - "--allow-empty") - - (test-assert "pushing, and the associated hooks" - (invoke #$(file-append git "/bin/git") "push"))) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) - - (gexp->derivation "gitolite" test)) - -(define %test-gitolite - (system-test - (name "gitolite") - (description "Clone the Gitolite admin repository.") - (value (run-gitolite-test)))) -- cgit v1.2.3 From f8e710684e5c3f866413dff825ba17bdffceac5d Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 13 Jul 2018 20:39:46 +0100 Subject: services: Add Gitolite. * gnu/services/version-control.scm (, ): New record types. (gitolite-accounts, gitolite-activation): New procedures. (gitolite-service-type): New variables. * gnu/tests/version-control.scm (%gitolite-test-admin-keypair, %gitolite-os, %test-gitolite): New variables. (run-gitolite-test): New procedure. * doc/guix.texi (Version Control): Document the gitolite service. --- doc/guix.texi | 94 ++++++++++++++++++++ gnu/services/version-control.scm | 180 ++++++++++++++++++++++++++++++++++++++- gnu/tests/version-control.scm | 114 ++++++++++++++++++++++++- 3 files changed, 386 insertions(+), 2 deletions(-) (limited to 'gnu/tests') diff --git a/doc/guix.texi b/doc/guix.texi index e1046eb512..94bb0ec4e1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -21028,6 +21028,100 @@ could instantiate a cgit service like this: (cgitrc ""))) @end example +@subsubheading Gitolite Service + +@cindex Gitolite service +@cindex Git, hosting +@uref{http://gitolite.com/gitolite/, Gitolite} is a tool for hosting Git +repositories on a central server. + +Gitolite can handle multiple repositories and users, and supports flexible +configuration of the permissions for the users on the repositories. + +The following example will configure Gitolite using the default @code{git} +user, and the provided SSH public key. + +@example +(service gitolite-service-type + (gitolite-configuration + (admin-pubkey (plain-file + "yourname.pub" + "ssh-rsa AAAA... guix@@example.com")))) +@end example + +Gitolite is configured through a special admin repository which you can clone, +for example, if you setup Gitolite on @code{example.com}, you would run the +following command to clone the admin repository. + +@example +git clone git@@example.com:gitolite-admin +@end example + +When the Gitolite service is activated, the provided @code{admin-pubkey} will +be inserted in to the @file{keydir} directory in the gitolite-admin +repository. If this results in a change in the repository, it will be +committed using the message ``gitolite setup by GNU Guix''. + +@deftp {Data Type} gitolite-configuration +Data type representing the configuration for @code{gitolite-service-type}. + +@table @asis +@item @code{package} (default: @var{gitolite}) +Gitolite package to use. + +@item @code{user} (default: @var{git}) +User to use for Gitolite. This will be user that you use when accessing +Gitolite over SSH. + +@item @code{group} (default: @var{git}) +Group to use for Gitolite. + +@item @code{home-directory} (default: @var{"/var/lib/gitolite"}) +Directory in which to store the Gitolite configuration and repositories. + +@item @code{rc-file} (default: @var{(gitolite-rc-file)}) +A ``file-like'' object (@pxref{G-Expressions, file-like objects}), +representing the configuration for Gitolite. + +@item @code{admin-pubkey} (default: @var{#f}) +A ``file-like'' object (@pxref{G-Expressions, file-like objects}) used to +setup Gitolite. This will be inserted in to the @file{keydir} directory +within the gitolite-admin repository. + +To specify the SSH key as a string, use the @code{plain-file} function. + +@example +(plain-file "yourname.pub" "ssh-rsa AAAA... guix@@example.com") +@end example + +@end table +@end deftp + +@deftp {Data Type} gitolite-rc-file +Data type representing the Gitolite RC file. + +@table @asis +@item @code{umask} (default: @code{#o0077}) +This controls the permissions Gitolite sets on the repositories and their +contents. + +A value like @code{#o0027} will give read access to the group used by Gitolite +(by default: @code{git}). This is necessary when using Gitolite with software +like cgit or gitweb. + +@item @code{git-config-keys} (default: @code{""}) +Gitolite allows you to set git config values using the "config" keyword. This +setting allows control over the config keys to accept. + +@item @code{roles} (default: @code{'(("READERS" . 1) ("WRITERS" . ))}) +Set the role names allowed to be used by users running the perms command. + +@item @code{enable} (default: @code{'("help" "desc" "info" "perms" "writable" "ssh-authkeys" "git-config" "daemon" "gitweb")}) +This setting controls the commands and features to enable within Gitolite. + +@end table +@end deftp + @node Game Services @subsubsection Game Services diff --git a/gnu/services/version-control.scm b/gnu/services/version-control.scm index 58274c8bee..13669925ab 100644 --- a/gnu/services/version-control.scm +++ b/gnu/services/version-control.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2016 Sou Bunnbu ;;; Copyright © 2017 Oleg Pykhalov ;;; Copyright © 2017 Clément Lassieur +;;; Copyright © 2018 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ #:use-module (guix store) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (git-daemon-service git-daemon-service-type @@ -40,7 +42,23 @@ git-http-configuration git-http-configuration? - git-http-nginx-location-configuration)) + git-http-nginx-location-configuration + + + gitolite-configuration + gitolite-configuration-package + gitolite-configuration-user + gitolite-configuration-rc-file + gitolite-configuration-admin-pubkey + + + gitolite-rc-file + gitolite-rc-file-umask + gitolite-rc-file-git-config-keys + gitolite-rc-file-roles + gitolite-rc-file-enable + + gitolite-service-type)) ;;; Commentary: ;;; @@ -197,3 +215,163 @@ access to exported repositories under @file{/srv/git}." "") (list "fastcgi_param GIT_PROJECT_ROOT " git-root ";") "fastcgi_param PATH_INFO $1;")))))) + + +;;; +;;; Gitolite +;;; + +(define-record-type* + gitolite-rc-file make-gitolite-rc-file + gitolite-rc-file? + (umask gitolite-rc-file-umask + (default #o0077)) + (git-config-keys gitolite-rc-file-git-config-keys + (default "")) + (roles gitolite-rc-file-roles + (default '(("READERS" . 1) + ("WRITERS" . 1)))) + (enable gitolite-rc-file-enable + (default '("help" + "desc" + "info" + "perms" + "writable" + "ssh-authkeys" + "git-config" + "daemon" + "gitweb")))) + +(define-gexp-compiler (gitolite-rc-file-compiler + (file ) system target) + (match file + (($ umask git-config-keys roles enable) + (apply text-file* "gitolite.rc" + `("%RC = (\n" + " UMASK => " ,(format #f "~4,'0o" umask) ",\n" + " GIT_CONFIG_KEYS => '" ,git-config-keys "',\n" + " ROLES => {\n" + ,@(map (match-lambda + ((role . value) + (simple-format #f " ~A => ~A,\n" role value))) + roles) + " },\n" + "\n" + " ENABLE => [\n" + ,@(map (lambda (value) + (simple-format #f " '~A',\n" value)) + enable) + " ],\n" + ");\n" + "\n" + "1;\n"))))) + +(define-record-type* + gitolite-configuration make-gitolite-configuration + gitolite-configuration? + (package gitolite-configuration-package + (default gitolite)) + (user gitolite-configuration-user + (default "git")) + (group gitolite-configuration-group + (default "git")) + (home-directory gitolite-configuration-home-directory + (default "/var/lib/gitolite")) + (rc-file gitolite-configuration-rc-file + (default (gitolite-rc-file))) + (admin-pubkey gitolite-configuration-admin-pubkey)) + +(define gitolite-accounts + (match-lambda + (($ package user group home-directory + rc-file admin-pubkey) + ;; User group and account to run Gitolite. + (list (user-group (name user) (system? #t)) + (user-account + (name user) + (group group) + (system? #t) + (comment "Gitolite user") + (home-directory home-directory)))))) + +(define gitolite-activation + (match-lambda + (($ package user group home + rc-file admin-pubkey) + #~(begin + (use-modules (ice-9 match) + (guix build utils)) + + (let* ((user-info (getpwnam #$user)) + (admin-pubkey #$admin-pubkey) + (pubkey-file (string-append + #$home "/" + (basename + (strip-store-file-name admin-pubkey))))) + + (simple-format #t "guix: gitolite: installing ~A\n" #$rc-file) + (copy-file #$rc-file #$(string-append home "/.gitolite.rc")) + + ;; The key must be writable, so copy it from the store + (copy-file admin-pubkey pubkey-file) + + (chmod pubkey-file #o500) + (chown pubkey-file + (passwd:uid user-info) + (passwd:gid user-info)) + + ;; Set the git configuration, to avoid gitolite trying to use + ;; the hostname command, as the network might not be up yet + (with-output-to-file #$(string-append home "/.gitconfig") + (lambda () + (display "[user] + name = GNU Guix + email = guix@localhost +"))) + ;; Run Gitolite setup, as this updates the hooks and include the + ;; admin pubkey if specified. The admin pubkey is required for + ;; initial setup, and will replace the previous key if run after + ;; initial setup + (match (primitive-fork) + (0 + ;; Exit with a non-zero status code if an exception is thrown. + (dynamic-wind + (const #t) + (lambda () + (setenv "HOME" (passwd:dir user-info)) + (setenv "USER" #$user) + (setgid (passwd:gid user-info)) + (setuid (passwd:uid user-info)) + (primitive-exit + (system* #$(file-append package "/bin/gitolite") + "setup" + "-m" "gitolite setup by GNU Guix" + "-pk" pubkey-file))) + (lambda () + (primitive-exit 1)))) + (pid (waitpid pid))) + + (when (file-exists? pubkey-file) + (delete-file pubkey-file))))))) + +(define gitolite-service-type + (service-type + (name 'gitolite) + (extensions + (list (service-extension activation-service-type + gitolite-activation) + (service-extension account-service-type + gitolite-accounts) + (service-extension profile-service-type + ;; The Gitolite package in Guix uses + ;; gitolite-shell in the authorized_keys file, so + ;; gitolite-shell needs to be on the PATH for + ;; gitolite to work. + (lambda (config) + (list + (gitolite-configuration-package config)))))) + (description + "Setup @command{gitolite}, a Git hosting tool providing access over SSH.. +By default, the @code{git} user is used, but this is configurable. +Additionally, Gitolite can integrate with with tools like gitweb or cgit to +provide a web interface to view selected repositories."))) diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm index 3b935a1b48..4409b8a12b 100644 --- a/gnu/tests/version-control.scm +++ b/gnu/tests/version-control.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017, 2018 Oleg Pykhalov ;;; Copyright © 2017, 2018 Ludovic Courtès ;;; Copyright © 2017, 2018 Clément Lassieur +;;; Copyright © 2018 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,14 +28,17 @@ #:use-module (gnu services) #:use-module (gnu services version-control) #:use-module (gnu services cgit) + #:use-module (gnu services ssh) #:use-module (gnu services web) #:use-module (gnu services networking) #:use-module (gnu packages version-control) + #:use-module (gnu packages ssh) #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix modules) #:export (%test-cgit - %test-git-http)) + %test-git-http + %test-gitolite)) (define README-contents "Hello! This is what goes inside the 'README' file.") @@ -300,3 +304,111 @@ HTTP-PORT." (name "git-http") (description "Connect to a running Git HTTP server.") (value (run-git-http-test)))) + + +;;; +;;; Gitolite. +;;; + +(define %gitolite-test-admin-keypair + (computed-file + "gitolite-test-admin-keypair" + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (ice-9 match) (srfi srfi-26) + (guix build utils)) + + (mkdir #$output) + (invoke #$(file-append openssh "/bin/ssh-keygen") + "-f" (string-append #$output "/test-admin") + "-t" "rsa" + "-q" + "-N" ""))))) + +(define %gitolite-os + (simple-operating-system + (dhcp-client-service) + (service openssh-service-type) + (service gitolite-service-type + (gitolite-configuration + (admin-pubkey + (file-append %gitolite-test-admin-keypair "/test-admin.pub")))))) + +(define (run-gitolite-test) + (define os + (marionette-operating-system + %gitolite-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((2222 . 22))))) + + (define test + (with-imported-modules '((gnu build marionette) + (guix build utils)) + #~(begin + (use-modules (srfi srfi-64) + (rnrs io ports) + (gnu build marionette) + (guix build utils)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "gitolite") + + ;; Wait for sshd to be up and running. + (test-assert "service running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'ssh-daemon)) + marionette)) + + (display #$%gitolite-test-admin-keypair) + + (setenv "GIT_SSH_VARIANT" "ssh") + (setenv "GIT_SSH_COMMAND" + (string-join + '(#$(file-append openssh "/bin/ssh") + "-i" #$(file-append %gitolite-test-admin-keypair + "/test-admin") + "-o" "UserKnownHostsFile=/dev/null" + "-o" "StrictHostKeyChecking=no"))) + + (test-assert "cloning the admin repository" + (invoke #$(file-append git "/bin/git") + "clone" "-v" + "ssh://git@localhost:2222/gitolite-admin" + "/tmp/clone")) + + (test-assert "admin key exists" + (file-exists? "/tmp/clone/keydir/test-admin.pub")) + + (with-directory-excursion "/tmp/clone" + (invoke #$(file-append git "/bin/git") + "-c" "user.name=Guix" "-c" "user.email=guix" + "commit" + "-m" "Test commit" + "--allow-empty") + + (test-assert "pushing, and the associated hooks" + (invoke #$(file-append git "/bin/git") "push"))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "gitolite" test)) + +(define %test-gitolite + (system-test + (name "gitolite") + (description "Clone the Gitolite admin repository.") + (value (run-gitolite-test)))) -- cgit v1.2.3 From 39d7fdce453b0ca23ecbed72048647debbaa58a6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 18 Oct 2018 00:45:05 +0200 Subject: services: dhcp-client: Deprecate 'dhcp-client-service' procedure. * gnu/services/networking.scm (dhcp-client-service-type): Add default value. * gnu/system/examples/bare-bones.tmpl: Use (service dhcp-client-service-type) instead of (dhcp-client-service). * gnu/system/examples/beaglebone-black.tmpl: Likewise. * gnu/tests/base.scm (%avahi-os): Likewise. * gnu/tests/databases.scm (%memcached-os): Likewise. (%mongodb-os): Likewise. * gnu/tests/dict.scm (%dicod-os): Likewise. * gnu/tests/mail.scm (%opensmtpd-os): Likewise. (%exim-os): Likewise. (%dovecot-os): Likewise. * gnu/tests/messaging.scm (run-xmpp-test): Likewise. (run-bitlbee-test): Likewise. * gnu/tests/monitoring.scm (%prometheus-node-exporter-os): Likewise. * gnu/tests/networking.scm (%inetd-os): Likewise. (run-iptables-test): Likewise. * gnu/tests/nfs.scm (%base-os): Likewise. * gnu/tests/rsync.scm (%rsync-os): Likewise. * gnu/tests/ssh.scm (run-ssh-test): Likewise. * gnu/tests/version-control.scm (%cgit-os): Likewise. (%git-http-os): Likewise. (%gitolite-os): Likewise. * gnu/tests/virtualization.scm (%libvirt-os): Likewise. * gnu/tests/web.scm (%httpd-os): Likewise. (%nginx-os): Likewise. (%varnish-os): Likewise. (%php-fpm-os): Likewise. (%hpcguix-web-os): Likewise. (%tailon-os): Likewise. * tests/guix-system.sh: Likewise. * doc/guix.texi (Networking Services): Document 'dhcp-client-service-type' and remove 'dhcp-client-service'. --- doc/guix.texi | 11 ++++++----- gnu/services/networking.scm | 6 ++++-- gnu/system/examples/bare-bones.tmpl | 2 +- gnu/system/examples/beaglebone-black.tmpl | 2 +- gnu/tests/base.scm | 2 +- gnu/tests/databases.scm | 4 ++-- gnu/tests/dict.scm | 2 +- gnu/tests/mail.scm | 6 +++--- gnu/tests/messaging.scm | 4 ++-- gnu/tests/monitoring.scm | 2 +- gnu/tests/networking.scm | 4 ++-- gnu/tests/nfs.scm | 2 +- gnu/tests/rsync.scm | 2 +- gnu/tests/ssh.scm | 2 +- gnu/tests/version-control.scm | 6 +++--- gnu/tests/virtualization.scm | 2 +- gnu/tests/web.scm | 12 ++++++------ guix/gexp.scm | 8 ++++++++ tests/guix-system.sh | 4 ++-- 19 files changed, 47 insertions(+), 36 deletions(-) (limited to 'gnu/tests') diff --git a/doc/guix.texi b/doc/guix.texi index fde7892cfd..f4f19949f1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11546,10 +11546,11 @@ The @code{(gnu services networking)} module provides services to configure the network interface. @cindex DHCP, networking service -@deffn {Scheme Procedure} dhcp-client-service [#:dhcp @var{isc-dhcp}] -Return a service that runs @var{dhcp}, a Dynamic Host Configuration -Protocol (DHCP) client, on all the non-loopback network interfaces. -@end deffn +@defvr {Scheme Variable} dhcp-client-service-type +This is the type of services that run @var{dhcp}, a Dynamic Host Configuration +Protocol (DHCP) client, on all the non-loopback network interfaces. Its value +is the DHCP client package to use, @code{isc-dhcp} by default. +@end defvr @deffn {Scheme Procedure} dhcpd-service-type This type defines a service that runs a DHCP daemon. To create a @@ -17168,7 +17169,7 @@ A helper function to quickly add php to an @code{nginx-server-configuration}. A simple services setup for nginx with php can look like this: @example -(services (cons* (dhcp-client-service) +(services (cons* (service dhcp-client-service-type) (service php-fpm-service-type) (service nginx-service-type (nginx-server-configuration diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index c809b4a4a4..61a0e975c7 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -53,6 +53,7 @@ static-networking-service-type) #:export (%facebook-host-aliases dhcp-client-service + dhcp-client-service-type dhcpd-service-type dhcpd-configuration @@ -202,9 +203,10 @@ fe80::1%lo0 apps.facebook.com\n") "-pf" #$pid-file ifaces)))) (and (zero? (cdr (waitpid pid))) (read-pid-file #$pid-file))))) - (stop #~(make-kill-destructor)))))) + (stop #~(make-kill-destructor)))) + isc-dhcp)) -(define* (dhcp-client-service #:key (dhcp isc-dhcp)) +(define* (dhcp-client-service #:key (dhcp isc-dhcp)) ;deprecated "Return a service that runs @var{dhcp}, a Dynamic Host Configuration Protocol (DHCP) client, on all the non-loopback network interfaces." (service dhcp-client-service-type dhcp)) diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index b763258e52..889dcabe64 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -44,7 +44,7 @@ ;; Add services to the baseline: a DHCP client and ;; an SSH server. - (services (cons* (dhcp-client-service) + (services (cons* (service dhcp-client-service-type) (service openssh-service-type (openssh-configuration (port-number 2222))) diff --git a/gnu/system/examples/beaglebone-black.tmpl b/gnu/system/examples/beaglebone-black.tmpl index d1130c76b6..efef682e3a 100644 --- a/gnu/system/examples/beaglebone-black.tmpl +++ b/gnu/system/examples/beaglebone-black.tmpl @@ -45,7 +45,7 @@ ;; Globally-installed packages. (packages (cons* screen openssh %base-packages)) - (services (cons* (dhcp-client-service) + (services (cons* (service dhcp-client-service-type) ;; mingetty does not work on serial lines. ;; Use agetty with board-specific serial parameters. (agetty-service diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index f97581de33..896d4a8f88 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -673,7 +673,7 @@ non-ASCII names from /tmp.") (name-service-switch %mdns-host-lookup-nss) (services (cons* (avahi-service #:debug? #t) (dbus-service) - (dhcp-client-service) ;needed for multicast + (service dhcp-client-service-type) ;needed for multicast ;; Enable heavyweight debugging output. (modify-services (operating-system-user-services diff --git a/gnu/tests/databases.scm b/gnu/tests/databases.scm index 5c8ca85c13..e0544bbcd2 100644 --- a/gnu/tests/databases.scm +++ b/gnu/tests/databases.scm @@ -35,7 +35,7 @@ (define %memcached-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service memcached-service-type))) (define* (run-memcached-test #:optional (port 11211)) @@ -130,7 +130,7 @@ (operating-system (inherit (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service mongodb-service-type))) (packages (cons* mongodb %base-packages)))) diff --git a/gnu/tests/dict.scm b/gnu/tests/dict.scm index dd60ffd464..c50e3cd6da 100644 --- a/gnu/tests/dict.scm +++ b/gnu/tests/dict.scm @@ -34,7 +34,7 @@ (define %dicod-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service dicod-service-type (dicod-configuration (interfaces '("0.0.0.0")) diff --git a/gnu/tests/mail.scm b/gnu/tests/mail.scm index 5677969fac..33aa4d3437 100644 --- a/gnu/tests/mail.scm +++ b/gnu/tests/mail.scm @@ -36,7 +36,7 @@ (define %opensmtpd-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service opensmtpd-service-type (opensmtpd-configuration (config-file @@ -155,7 +155,7 @@ accept from any for local deliver to mbox (define %exim-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service mail-aliases-service-type '()) (service exim-service-type (exim-configuration @@ -283,7 +283,7 @@ acl_check_data: (define %dovecot-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (dovecot-service #:config (dovecot-configuration (disable-plaintext-auth? #f) diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm index f5f99b9f56..36afb987af 100644 --- a/gnu/tests/messaging.scm +++ b/gnu/tests/messaging.scm @@ -35,7 +35,7 @@ "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE." (define os (marionette-operating-system - (simple-operating-system (dhcp-client-service) + (simple-operating-system (service dhcp-client-service-type) xmpp-service) #:imported-modules '((gnu services herd)))) @@ -167,7 +167,7 @@ (define (run-bitlbee-test) (define os (marionette-operating-system - (simple-operating-system (dhcp-client-service) + (simple-operating-system (service dhcp-client-service-type) (service bitlbee-service-type (bitlbee-configuration (interface "0.0.0.0")))) diff --git a/gnu/tests/monitoring.scm b/gnu/tests/monitoring.scm index 67899987ce..3320a19a77 100644 --- a/gnu/tests/monitoring.scm +++ b/gnu/tests/monitoring.scm @@ -85,7 +85,7 @@ (define %prometheus-node-exporter-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service prometheus-node-exporter-service-type (prometheus-node-exporter-configuration)))) diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm index ceba7f7d5d..9f12a4ae8d 100644 --- a/gnu/tests/networking.scm +++ b/gnu/tests/networking.scm @@ -39,7 +39,7 @@ (define %inetd-os ;; Operating system with 2 inetd services. (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service inetd-service-type (inetd-configuration (entries (list @@ -463,7 +463,7 @@ COMMIT (define os (marionette-operating-system (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service inetd-service-type (inetd-configuration (entries (list diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm index 140f03779b..7ef9f1f7bf 100644 --- a/gnu/tests/nfs.scm +++ b/gnu/tests/nfs.scm @@ -55,7 +55,7 @@ (services (cons* (service rpcbind-service-type (rpcbind-configuration)) - (dhcp-client-service) + (service dhcp-client-service-type) %base-services)))) (define (run-nfs-test name socket) diff --git a/gnu/tests/rsync.scm b/gnu/tests/rsync.scm index a6f8fa2bd1..096580022f 100644 --- a/gnu/tests/rsync.scm +++ b/gnu/tests/rsync.scm @@ -111,7 +111,7 @@ PORT." ;; Return operating system under test. (let ((base-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service rsync-service-type)))) (operating-system (inherit base-os) diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm index 2e40122add..e5cd439cdf 100644 --- a/gnu/tests/ssh.scm +++ b/gnu/tests/ssh.scm @@ -39,7 +39,7 @@ empty-password logins. When SFTP? is true, run an SFTP server test." (define os (marionette-operating-system - (simple-operating-system (dhcp-client-service) ssh-service) + (simple-operating-system (service dhcp-client-service-type) ssh-service) #:imported-modules '((gnu services herd) (guix combinators)))) (define vm diff --git a/gnu/tests/version-control.scm b/gnu/tests/version-control.scm index 4409b8a12b..230aa9edf9 100644 --- a/gnu/tests/version-control.scm +++ b/gnu/tests/version-control.scm @@ -92,7 +92,7 @@ ;; Operating system under test. (let ((base-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service cgit-service-type (cgit-configuration (nginx %cgit-configuration-nginx))) @@ -237,7 +237,7 @@ HTTP-PORT." (define %git-http-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service fcgiwrap-service-type) (service nginx-service-type %git-nginx-configuration) %test-repository-service)) @@ -328,7 +328,7 @@ HTTP-PORT." (define %gitolite-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service openssh-service-type) (service gitolite-service-type (gitolite-configuration diff --git a/gnu/tests/virtualization.scm b/gnu/tests/virtualization.scm index c2939355b2..fbdec20805 100644 --- a/gnu/tests/virtualization.scm +++ b/gnu/tests/virtualization.scm @@ -32,7 +32,7 @@ (define %libvirt-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (dbus-service) (polkit-service) (service libvirt-service-type))) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 2e209fee97..319655396a 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -125,7 +125,7 @@ HTTP-PORT." (define %httpd-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service httpd-service-type (httpd-configuration (config @@ -154,7 +154,7 @@ HTTP-PORT." (define %nginx-os ;; Operating system under test. (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service nginx-service-type (nginx-configuration (log-directory "/var/log/nginx") @@ -188,7 +188,7 @@ sub vcl_synth { (define %varnish-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) ;; Pretend to be a web server that serves %index.html-contents. (service varnish-service-type (varnish-configuration @@ -237,7 +237,7 @@ echo(\"Computed by php:\".((string)(2+3))); (define %php-fpm-os ;; Operating system under test. (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service php-fpm-service-type) (service nginx-service-type (nginx-configuration @@ -392,7 +392,7 @@ HTTP-PORT, along with php-fpm." (define %hpcguix-web-os (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service hpcguix-web-service-type (hpcguix-web-configuration (specs %hpcguix-web-specs))))) @@ -407,7 +407,7 @@ HTTP-PORT, along with php-fpm." (define %tailon-os ;; Operating system under test. (simple-operating-system - (dhcp-client-service) + (service dhcp-client-service-type) (service tailon-service-type (tailon-configuration (config-file diff --git a/guix/gexp.scm b/guix/gexp.scm index f7a23db872..ba0d642b17 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -438,6 +438,14 @@ This is the declarative counterpart of 'gexp->file'." (base file-append-base) ; | | ... (suffix file-append-suffix)) ;list of strings +(define (write-file-append file port) + (match file + (($ base suffix) + (format port "#" base + (string-join suffix))))) + +(set-record-type-printer! write-file-append) + (define (file-append base . suffix) "Return a object that expands to the concatenation of BASE and SUFFIX." diff --git a/tests/guix-system.sh b/tests/guix-system.sh index a129efdfcb..23d2da4903 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -153,8 +153,8 @@ cat > "$tmpfile" < Date: Tue, 13 Nov 2018 11:02:13 +0100 Subject: services: nscd: Add 'invalidate' and 'statistics' actions. * gnu/services/base.scm (nscd-action-procedure, nscd-actions): New procedures. (nscd-shepherd-service): Add 'modules' and 'actions' fields. * gnu/tests/base.scm (run-basic-test)["nscd invalidate action"] ["nscd invalidate action, wrong table"]: New tests. * doc/guix.texi (Services): Mention 'herd doc nscd action'. (Base Services): Document the actions. --- doc/guix.texi | 26 ++++++++++++++++++++++++- gnu/services/base.scm | 54 ++++++++++++++++++++++++++++++++++++++++++++++----- gnu/tests/base.scm | 14 +++++++++++++ 3 files changed, 88 insertions(+), 6 deletions(-) (limited to 'gnu/tests') diff --git a/doc/guix.texi b/doc/guix.texi index 4b082c5f87..0ba034e822 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10563,11 +10563,14 @@ Start,,, shepherd, The GNU Shepherd Manual}). For example: The above command, run as @code{root}, lists the currently defined services. The @command{herd doc} command shows a synopsis of the given -service: +service and its associated actions: @example # herd doc nscd Run libc's name service cache daemon (nscd). + +# herd doc nscd action invalidate +invalidate: Invalidate the given cache--e.g., 'hosts' for host name lookups. @end example The @command{start}, @command{stop}, and @command{restart} sub-commands @@ -10965,6 +10968,27 @@ The Kmscon package to use. Return a service that runs the libc name service cache daemon (nscd) with the given @var{config}---an @code{} object. @xref{Name Service Switch}, for an example. + +For convenience, the Shepherd service for nscd provides the following actions: + +@table @code +@item invalidate +@cindex cache invalidation, nscd +@cindex nscd, cache invalidation +This invalidate the given cache. For instance, running: + +@example +herd invalidate nscd hosts +@end example + +@noindent +invalidates the host name lookup cache of nscd. + +@item statistics +Running @command{herd statistics nscd} displays information about nscd usage +and caches. +@end table + @end deffn @defvr {Scheme Variable} %nscd-default-configuration diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 3409bd352c..228d3c5926 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1252,18 +1252,57 @@ the tty to run, among other things." (string-concatenate (map cache->config caches))))))) +(define (nscd-action-procedure nscd config option) + ;; XXX: This is duplicated from mcron; factorize. + #~(lambda (_ . args) + ;; Run 'nscd' in a pipe so we can explicitly redirect its output to + ;; 'current-output-port', which at this stage is bound to the client + ;; connection. + (let ((pipe (apply open-pipe* OPEN_READ #$nscd + "-f" #$config #$option args))) + (let loop () + (match (read-line pipe 'concat) + ((? eof-object?) + (catch 'system-error + (lambda () + (zero? (close-pipe pipe))) + (lambda args + ;; There's a race with the SIGCHLD handler, which could + ;; call 'waitpid' before 'close-pipe' above does. If we + ;; get ECHILD, that means we lost the race, but that's + ;; fine. + (or (= ECHILD (system-error-errno args)) + (apply throw args))))) + (line + (display line) + (loop))))))) + +(define (nscd-actions nscd config) + "Return Shepherd actions for NSCD." + ;; Make this functionality available as actions because that's a simple way + ;; to run the right 'nscd' binary with the right config file. + (list (shepherd-action + (name 'statistics) + (documentation "Display statistics about nscd usage.") + (procedure (nscd-action-procedure nscd config "--statistics"))) + (shepherd-action + (name 'invalidate) + (documentation + "Invalidate the given cache--e.g., 'hosts' for host name lookups.") + (procedure (nscd-action-procedure nscd config "--invalidate"))))) + (define (nscd-shepherd-service config) "Return a shepherd service for CONFIG, an object." - (let ((nscd.conf (nscd.conf-file config)) + (let ((nscd (file-append (nscd-configuration-glibc config) + "/sbin/nscd")) + (nscd.conf (nscd.conf-file config)) (name-services (nscd-configuration-name-services config))) (list (shepherd-service (documentation "Run libc's name service cache daemon (nscd).") (provision '(nscd)) (requirement '(user-processes)) (start #~(make-forkexec-constructor - (list #$(file-append (nscd-configuration-glibc config) - "/sbin/nscd") - "-f" #$nscd.conf "--foreground") + (list #$nscd "-f" #$nscd.conf "--foreground") ;; Wait for the PID file. However, the PID file is ;; written before nscd is actually listening on its @@ -1277,7 +1316,12 @@ the tty to run, among other things." (string-append dir "/lib")) (list #$@name-services)) ":"))))) - (stop #~(make-kill-destructor)))))) + (stop #~(make-kill-destructor)) + (modules `((ice-9 popen) ;for the actions + (ice-9 rdelim) + (ice-9 match) + ,@%default-modules)) + (actions (nscd-actions nscd nscd.conf)))))) (define nscd-activation ;; Actions to take before starting nscd. diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 896d4a8f88..02882f4b46 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -335,6 +335,20 @@ info --version") (x (pk 'failure x #f)))) + (test-equal "nscd invalidate action" + '(#t) ;one value, #t + (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts") + result + result) + marionette)) + + (test-equal "nscd invalidate action, wrong table" + '(#f) ;one value, #f + (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz") + result + result) + marionette)) + (test-equal "host not found" #f (marionette-eval -- cgit v1.2.3 From b297934437932de730432629b361fcb422accbb7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 18 Nov 2018 23:34:19 +0100 Subject: activation: Aways pass '-d HOME' to 'useradd'. Fixes . Reported by fps. * gnu/build/activation.scm (add-user): Always pass "-d HOME" when HOME is true. Pass "--create-home" only when HOME, CREATE-HOME?, and SYSTEM? are true. (activate-users+groups): Pass #:create-home? create-home? to 'ensure-user'. * gnu/tests/base.scm (run-basic-test)["accounts"]: Test 'passwd:dir' as well. --- gnu/build/activation.scm | 17 +++++++++-------- gnu/tests/base.scm | 11 ++++++++--- 2 files changed, 17 insertions(+), 11 deletions(-) (limited to 'gnu/tests') diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm index 68ecd6bc71..0e77677de1 100644 --- a/gnu/build/activation.scm +++ b/gnu/build/activation.scm @@ -148,11 +148,15 @@ properties. Return #t on success." `("-G" ,(string-join supplementary-groups ",")) '()) ,@(if comment `("-c" ,comment) '()) - ,@(if (and home create-home?) - (if (file-exists? home) - `("-d" ,home) ; avoid warning from 'useradd' - `("-d" ,home "--create-home")) + ,@(if home `("-d" ,home) '()) + + ;; Home directories of non-system accounts are created by + ;; 'activate-user-home'. + ,@(if (and home create-home? system? + (not (file-exists? home))) + '("--create-home") '()) + ,@(if shell `("-s" ,shell) '()) ,@(if password `("-p" ,password) '()) ,@(if system? '("--system") '()) @@ -229,10 +233,7 @@ numeric gid or #f." #:supplementary-groups supplementary-groups #:comment comment #:home home - - ;; Home directories of non-system accounts are created by - ;; 'activate-user-home'. - #:create-home? (and create-home? system?) + #:create-home? create-home? #:shell shell #:password password) diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 02882f4b46..03392cef38 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -154,10 +154,15 @@ info --version") (#f (reverse result)) (x (loop (cons x result)))))) marionette))) - (lset= string=? - (map passwd:name users) + (lset= equal? + (map (lambda (user) + (list (passwd:name user) + (passwd:dir user))) + users) (list - #$@(map user-account-name + #$@(map (lambda (account) + `(list ,(user-account-name account) + ,(user-account-home-directory account))) (operating-system-user-accounts os)))))) (test-assert "shepherd services" -- cgit v1.2.3