me
/
guix
Archived
1
0
Fork 0
This repository has been archived on 2024-08-07. You can view files and clone it, but cannot push or open issues/pull-requests.
guix/gnu/services/admin.scm

345 lines
13 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of thye GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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
log-rotation
log-rotation?
log-rotation-frequency
log-rotation-files
log-rotation-options
log-rotation-post-rotate
rottlog-configuration
rottlog-configuration?
rottlog-service
rottlog-service-type
<tailon-configuration-file>
tailon-configuration-file
tailon-configuration-file?
tailon-configuration-file-files
tailon-configuration-file-bind
tailon-configuration-file-relative-root
tailon-configuration-file-allow-transfers?
tailon-configuration-file-follow-names?
tailon-configuration-file-tail-lines
tailon-configuration-file-allowed-commands
tailon-configuration-file-debug?
tailon-configuration-file-http-auth
tailon-configuration-file-users
<tailon-configuration>
tailon-configuration
tailon-configuration?
tailon-configuration-config-file
tailon-configuration-package
tailon-service-type))
;;; Commentary:
;;;
;;; This module implements configuration of rottlog by writing
;;; /etc/rottlog/{rc,hourly|daily|weekly}. Example usage
;;;
;;; (mcron-service)
;;; (service rottlog-service-type)
;;;
;;; Code:
(define-record-type* <log-rotation> log-rotation make-log-rotation
log-rotation?
(files log-rotation-files) ;list of strings
(frequency log-rotation-frequency ;symbol
(default 'weekly))
(post-rotate log-rotation-post-rotate ;#f | gexp
(default #f))
(options log-rotation-options ;list of strings
(default '())))
(define %rotated-files
;; Syslog files subject to rotation.
'("/var/log/messages" "/var/log/secure" "/var/log/maillog"))
(define %default-rotations
(list (log-rotation ;syslog files
(files %rotated-files)
;; Restart syslogd after rotation.
(options '("sharedscripts"))
(post-rotate #~(let ((pid (call-with-input-file "/var/run/syslog.pid"
read)))
(kill pid SIGHUP))))
(log-rotation
(files '("/var/log/shepherd.log" "/var/log/guix-daemon.log")))))
(define (log-rotation->config rotation)
"Return a string-valued gexp representing the rottlog configuration snippet
for ROTATION."
(define post-rotate
(let ((post (log-rotation-post-rotate rotation)))
(and post
(program-file "rottlog-post-rotate.scm" post))))
#~(let ((post #$post-rotate))
(string-append (string-join '#$(log-rotation-files rotation) ",")
" {"
#$(string-join (log-rotation-options rotation)
"\n " 'prefix)
(if post
(string-append "\n postrotate\n " post
"\n endscript\n")
"")
"\n}\n")))
(define (log-rotations->/etc-entries rotations)
"Return the list of /etc entries for ROTATIONS, a list of <log-rotation>."
(define (frequency-file frequency rotations)
(computed-file (string-append "rottlog." (symbol->string frequency))
#~(call-with-output-file #$output
(lambda (port)
(for-each (lambda (str)
(display str port))
(list #$@(map log-rotation->config
rotations)))))))
(let* ((frequencies (delete-duplicates
(map log-rotation-frequency rotations)))
(table (fold (lambda (rotation table)
(vhash-consq (log-rotation-frequency rotation)
rotation table))
vlist-null
rotations)))
(map (lambda (frequency)
`(,(symbol->string frequency)
,(frequency-file frequency
(vhash-foldq* cons '() frequency table))))
frequencies)))
(define (default-jobs rottlog)
(list #~(job '(next-hour '(0)) ;midnight
(lambda ()
(system* #$(file-append rottlog "/sbin/rottlog"))))
#~(job '(next-hour '(12)) ;noon
(lambda ()
(system* #$(file-append rottlog "/sbin/rottlog"))))))
(define-record-type* <rottlog-configuration>
rottlog-configuration make-rottlog-configuration
rottlog-configuration?
(rottlog rottlog-rottlog ;package
(default rottlog))
(rc-file rottlog-rc-file ;file-like
(default (file-append rottlog "/etc/rc")))
(rotations rottlog-rotations ;list of <log-rotation>
(default %default-rotations))
(jobs rottlog-jobs ;list of <mcron-job>
(default #f)))
(define (rottlog-etc config)
`(("rottlog"
,(file-union "rottlog"
(cons `("rc" ,(rottlog-rc-file config))
(log-rotations->/etc-entries
(rottlog-rotations config)))))))
(define (rottlog-jobs-or-default config)
(or (rottlog-jobs config)
(default-jobs (rottlog-rottlog config))))
(define rottlog-service-type
(service-type
(name 'rottlog)
(extensions (list (service-extension etc-service-type rottlog-etc)
(service-extension mcron-service-type
rottlog-jobs-or-default)
;; Add Rottlog to the global profile so users can access
;; the documentation.
(service-extension profile-service-type
(compose list rottlog-rottlog))))
(compose concatenate)
(extend (lambda (config rotations)
(rottlog-configuration
(inherit config)
(rotations (append (rottlog-rotations config)
rotations)))))
(default-value (rottlog-configuration))))
;;;
;;; Tailon
;;;
(define-record-type* <tailon-configuration-file>
tailon-configuration-file make-tailon-configuration-file
tailon-configuration-file?
(files tailon-configuration-file-files
(default '("/var/log")))
(bind tailon-configuration-file-bind
(default "localhost:8080"))
(relative-root tailon-configuration-file-relative-root
(default #f))
(allow-transfers? tailon-configuration-file-allow-transfers?
(default #t))
(follow-names? tailon-configuration-file-follow-names?
(default #t))
(tail-lines tailon-configuration-file-tail-lines
(default 200))
(allowed-commands tailon-configuration-file-allowed-commands
(default '("tail" "grep" "awk")))
(debug? tailon-configuration-file-debug?
(default #f))
(wrap-lines tailon-configuration-file-wrap-lines
(default #t))
(http-auth tailon-configuration-file-http-auth
(default #f))
(users tailon-configuration-file-users
(default #f)))
(define (tailon-configuration-files-string files)
(string-append
"\n"
(string-join
(map
(lambda (x)
(string-append
" - "
(cond
((string? x)
(simple-format #f "'~A'" x))
((list? x)
(string-join
(cons (simple-format #f "'~A':" (car x))
(map
(lambda (x) (simple-format #f " - '~A'" x))
(cdr x)))
"\n"))
(else (error x)))))
files)
"\n")))
(define-gexp-compiler (tailon-configuration-file-compiler
(file <tailon-configuration-file>) system target)
(match file
(($ <tailon-configuration-file> files bind relative-root
allow-transfers? follow-names?
tail-lines allowed-commands debug?
wrap-lines http-auth users)
(text-file
"tailon-config.yaml"
(string-concatenate
(filter-map
(match-lambda
((key . #f) #f)
((key . value) (string-append key ": " value "\n")))
`(("files" . ,(tailon-configuration-files-string files))
("bind" . ,bind)
("relative-root" . ,relative-root)
("allow-transfers" . ,(if allow-transfers? "true" "false"))
("follow-names" . ,(if follow-names? "true" "false"))
("tail-lines" . ,(number->string tail-lines))
("commands" . ,(string-append "["
(string-join allowed-commands ", ")
"]"))
("debug" . ,(if debug? "true" #f))
("wrap-lines" . ,(if wrap-lines "true" "false"))
("http-auth" . ,http-auth)
("users" . ,(if users
(string-concatenate
(cons "\n"
(map (match-lambda
((user . pass)
(string-append
" " user ":" pass)))
users)))
#f)))))))))
(define-record-type* <tailon-configuration>
tailon-configuration make-tailon-configuration
tailon-configuration?
(config-file tailon-configuration-config-file
(default (tailon-configuration-file)))
(package tailon-configuration-package
(default tailon)))
(define tailon-shepherd-service
(match-lambda
(($ <tailon-configuration> config-file package)
(list (shepherd-service
(provision '(tailon))
(documentation "Run the tailon daemon.")
(start #~(make-forkexec-constructor
`(,(string-append #$package "/bin/tailon")
"-c" ,#$config-file)
#:user "tailon"
#:group "tailon"))
(stop #~(make-kill-destructor)))))))
(define %tailon-accounts
(list (user-group (name "tailon") (system? #t))
(user-account
(name "tailon")
(group "tailon")
(system? #t)
(comment "tailon")
(home-directory "/var/empty")
(shell (file-append shadow "/sbin/nologin")))))
(define tailon-service-type
(service-type
(name 'tailon)
(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