mirror of
git://git.savannah.gnu.org/guix/maintenance.git
synced 2023-12-14 03:33:04 +01:00
7fbe51143d
* hydra/modules/sysadmin/services.scm (disk-space-check) (disk-space-mcron-jobs, disk-space-watchdog-service-type): New variables. * hydra/berlin.scm <services>: Use it.
592 lines
24 KiB
Scheme
592 lines
24 KiB
Scheme
;;; GNU Guix system administration tools.
|
||
;;;
|
||
;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
|
||
;;; Copyright © 2017, 2018, 2020 Ricardo Wurmus <rekado@elephly.net>
|
||
;;;
|
||
;;; This program 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.
|
||
;;;
|
||
;;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (sysadmin services)
|
||
#:use-module (guix gexp)
|
||
#:use-module (guix modules)
|
||
#:use-module ((guix self) #:select (make-config.scm))
|
||
#:use-module ((guix store) #:select (%store-prefix))
|
||
#:use-module (gnu services)
|
||
#:use-module (gnu services admin)
|
||
#:use-module (gnu services base)
|
||
#:use-module (gnu services cuirass)
|
||
#:use-module (gnu services mcron)
|
||
#:use-module (gnu services shepherd)
|
||
#:use-module (gnu services ssh)
|
||
#:use-module (gnu services web)
|
||
#:use-module (gnu system shadow)
|
||
#:use-module (guix packages)
|
||
#:use-module (gnu packages)
|
||
#:use-module (gnu packages admin)
|
||
#:use-module (gnu packages base)
|
||
#:use-module (gnu packages ci)
|
||
#:use-module (gnu packages gnupg)
|
||
#:use-module (gnu packages guile-xyz)
|
||
#:use-module (gnu packages linux)
|
||
#:use-module (gnu packages package-management)
|
||
#:use-module (gnu packages tls)
|
||
#:use-module (gnu packages web)
|
||
#:use-module (sysadmin people)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (ice-9 match)
|
||
#:export (firewall-service
|
||
disk-space-watchdog-service-type
|
||
frontend-services
|
||
KiB MiB GiB TiB
|
||
goggles-service-type))
|
||
|
||
(define not-config?
|
||
;; Select (guix …) and (gnu …) modules, except (guix config).
|
||
(match-lambda
|
||
(('guix 'config) #f)
|
||
(('guix _ ...) #t)
|
||
(('gnu _ ...) #t)
|
||
(_ #f)))
|
||
|
||
(define cleanup-cuirass-roots
|
||
;; This program removes Cuirass GC roots that correspond to disk
|
||
;; images--which typically take 2+GiB and are produced at a high rate--so
|
||
;; that there's more garbage to collect.
|
||
(program-file
|
||
"cleanup-cuirass-roots"
|
||
(with-extensions (list guile-gcrypt)
|
||
(with-imported-modules `(,@(source-module-closure
|
||
'((guix store)
|
||
(guix derivations))
|
||
#:select? not-config?)
|
||
((guix config) => ,(make-config.scm)))
|
||
#~(begin
|
||
(use-modules (ice-9 ftw)
|
||
(srfi srfi-1)
|
||
(guix store)
|
||
(guix derivations))
|
||
|
||
(define %roots-directory
|
||
"/var/guix/profiles/per-user/cuirass/cuirass")
|
||
|
||
(define now
|
||
(current-time))
|
||
|
||
(define (old? stat)
|
||
(< (stat:mtime stat)
|
||
(- now (* 5 3600 24))))
|
||
|
||
(define (handle-gc-root file stat deleted)
|
||
;; Remove disk images, including *-installation (disk
|
||
;; images of the targets of installation tests.)
|
||
(if (and (or (string-suffix? "-test" file)
|
||
(string-suffix? "-run-vm.sh" file)
|
||
(string-suffix? "-disk-image" file)
|
||
(string-suffix? "-iso9660-image" file)
|
||
(string-suffix? "-iso-image-installer" file)
|
||
(string-suffix? "-qemu-image" file)
|
||
(string-suffix? ".squashfs" file)
|
||
(string-suffix? "docker-pack.tar.gz" file)
|
||
(string-suffix? "docker-image.tar.gz" file)
|
||
(string-suffix? "guix-binary.tar.xz" file)
|
||
(string-suffix? "partition.img" file)
|
||
(string-suffix? "genimage.cfg" file)
|
||
(string-suffix? "-os" file)
|
||
(string-suffix? "-os-encrypted" file)
|
||
(string-suffix? "-installation" file))
|
||
(old? stat))
|
||
(catch 'system-error
|
||
(lambda ()
|
||
(delete-file file)
|
||
(cons file deleted))
|
||
(lambda args
|
||
(format (current-error-port)
|
||
"failed to delete ~a ~a~%" file
|
||
(system-error-errno args))
|
||
deleted))
|
||
deleted))
|
||
|
||
(define (root-target root)
|
||
;; Return the store item ROOT refers to.
|
||
(string-append (%store-prefix) "/" (basename root)))
|
||
|
||
(define (derivation-referrers store item)
|
||
;; Return the referrers of the derivers of ITEM.
|
||
(let* ((derivers (valid-derivers store item))
|
||
(referrers (append-map (lambda (drv)
|
||
(referrers store drv))
|
||
derivers)))
|
||
(delete-duplicates referrers)))
|
||
|
||
(define (delete-gc-root-for-derivation drv)
|
||
;; Delete the GC root for DRV, if any.
|
||
(catch 'system-error
|
||
(lambda ()
|
||
(let ((item (derivation-path->output-path drv)))
|
||
(delete-file
|
||
(string-append %roots-directory
|
||
"/" (basename drv)))))
|
||
(const #f)))
|
||
|
||
;; Note: 'scandir' would introduce too much overhead due
|
||
;; to the large number of entries that it would sort.
|
||
(define deleted
|
||
(file-system-fold (const #t) ;enter?
|
||
handle-gc-root
|
||
(lambda (file stat result) result) ;down
|
||
(lambda (file stat result) result) ;up
|
||
(lambda (file stat result) result) ;skip
|
||
(lambda (file stat errno result) result) ;error
|
||
'()
|
||
%roots-directory
|
||
lstat))
|
||
|
||
(call-with-output-file "/gnu/big-stuff"
|
||
(lambda (port)
|
||
(for-each (lambda (file)
|
||
(display file port)
|
||
(newline port))
|
||
deleted)))
|
||
|
||
;; Since we run 'guix-daemon --gc-keep-outputs
|
||
;; --gc-keep-derivations', also remove GC roots for the outputs of
|
||
;; derivations that refer to the derivers of DELETED.
|
||
(for-each delete-gc-root-for-derivation
|
||
(with-store store
|
||
(append-map (lambda (root)
|
||
(derivation-referrers
|
||
store (root-target root)))
|
||
deleted))))))))
|
||
|
||
(define (gc-jobs threshold)
|
||
"Return the garbage collection mcron jobs."
|
||
(list #~(job '(next-hour '(3))
|
||
#$cleanup-cuirass-roots)
|
||
|
||
#~(job '(next-hour '(4))
|
||
(string-append #$guix "/bin/guix gc -F"
|
||
#$(number->string threshold)))
|
||
|
||
;; Half a day later, make sure half of our quota is available.
|
||
#~(job '(next-hour '(16))
|
||
(string-append #$guix "/bin/guix gc -F"
|
||
#$(number->string
|
||
(quotient threshold 2))))))
|
||
|
||
(define* (guix-daemon-config #:key (max-jobs 5) (cores 4)
|
||
(build-accounts-to-max-jobs-ratio 4))
|
||
(guix-configuration
|
||
;; Disable substitutes altogether.
|
||
(use-substitutes? #f)
|
||
(substitute-urls '())
|
||
(authorized-keys '())
|
||
|
||
;; We don't want to let builds get stuck for too long, but we still want
|
||
;; to allow building, say, Guile 2.2 on armhf-linux, which takes < 3h on
|
||
;; an OverDrive 1000.
|
||
(max-silent-time 3600)
|
||
(timeout (* 6 3600))
|
||
|
||
(log-compression 'gzip) ;be friendly to 'guix publish' users
|
||
|
||
(build-accounts (* build-accounts-to-max-jobs-ratio max-jobs))
|
||
(extra-options (list "--max-jobs" (number->string max-jobs)
|
||
"--cores" (number->string cores)
|
||
"--cache-failures"
|
||
"--gc-keep-outputs" "--gc-keep-derivations"))))
|
||
|
||
|
||
;;;
|
||
;;; Cuirass.
|
||
;;;
|
||
|
||
(define* (guix-input name #:optional (branch "master"))
|
||
`((#:name . ,name)
|
||
(#:url . "https://git.savannah.gnu.org/git/guix.git")
|
||
(#:load-path . ".")
|
||
(#:branch . ,branch)
|
||
(#:no-compile? . #t)))
|
||
|
||
(define (cuirass-specs branches systems)
|
||
"Return the Cuirass specifications to build Guix for the given SYSTEMS."
|
||
#~(list
|
||
#$@(if (member "master" branches)
|
||
#~(`((#:name . "guix-master")
|
||
(#:load-path-inputs . ())
|
||
(#:package-path-inputs . ())
|
||
(#:proc-input . "guix")
|
||
(#:proc-file . "build-aux/cuirass/gnu-system.scm")
|
||
(#:proc . cuirass-jobs)
|
||
(#:proc-args (subset . "all") (systems #$@systems))
|
||
(#:inputs . (#$(guix-input "guix" "master")))
|
||
;; Save the build output of the ISO9660-IMAGE job.
|
||
(#:build-outputs . (((#:job . "iso9660-image*")
|
||
(#:type . "ISO-9660")
|
||
(#:output . "out")
|
||
(#:path . ""))
|
||
((#:job . "hurd-barebones-disk-image*")
|
||
(#:type . "image")
|
||
(#:output . "out")
|
||
(#:path . "")))))
|
||
`((#:name . "guix-modular-master")
|
||
;; Keep the load path empty: it uses the available Guix modules
|
||
;; to build a trampoline.
|
||
(#:load-path-inputs . ())
|
||
(#:package-path-inputs . ())
|
||
(#:proc-input . "guix-modular")
|
||
(#:proc-file . "build-aux/cuirass/guix-modular.scm")
|
||
(#:proc . cuirass-jobs)
|
||
(#:proc-args (systems #$@systems))
|
||
(#:inputs . (#$(guix-input "guix-modular" "master")))
|
||
(#:build-outputs . ())))
|
||
#~())
|
||
#$@(if (member "staging" branches)
|
||
#~(`((#:name . "staging-staging")
|
||
(#:load-path-inputs . ())
|
||
(#:package-path-inputs . ())
|
||
(#:proc-input . "staging")
|
||
(#:proc-file . "build-aux/cuirass/gnu-system.scm")
|
||
(#:proc . cuirass-jobs)
|
||
(#:proc-args (systems #$@systems))
|
||
(#:inputs . (#$(guix-input "staging" "staging")))
|
||
(#:build-outputs . ())))
|
||
#~())
|
||
#$@(if (member "core-updates" branches)
|
||
#~(`((#:name . "core-updates-core-updates")
|
||
(#:load-path-inputs . ())
|
||
(#:package-path-inputs . ())
|
||
(#:proc-input . "core-updates")
|
||
(#:proc-file . "build-aux/cuirass/gnu-system.scm")
|
||
(#:proc . cuirass-jobs)
|
||
(#:proc-args (subset . core) (systems #$@systems))
|
||
(#:inputs . (#$(guix-input "core-updates" "core-updates")))
|
||
(#:build-outputs . ())))
|
||
#~())))
|
||
|
||
|
||
;;;
|
||
;;; Firewall.
|
||
;;;
|
||
|
||
(define start-firewall
|
||
;; Rules to throttle malicious SSH connection attempts. This will allow at
|
||
;; most 3 connections per minute from any host, and will block the host for
|
||
;; another minute if this rate is exceeded. Taken from
|
||
;; <http://www.la-samhna.de/library/brutessh.html#3>.
|
||
#~(let ((iptables
|
||
(lambda (str)
|
||
(zero? (apply system*
|
||
#$(file-append iptables
|
||
"/sbin/iptables")
|
||
(string-tokenize str))))))
|
||
(format #t "Installing iptables SSH rules...~%")
|
||
(and (iptables "-A INPUT -p tcp --dport 22 -m state \
|
||
--state NEW -m recent --set --name SSH -j ACCEPT")
|
||
(iptables "-A INPUT -p tcp --dport 22 -m recent \
|
||
--update --seconds 60 --hitcount 4 --rttl \
|
||
--name SSH -j LOG --log-prefix SSH_brute_force")
|
||
(iptables "-A INPUT -p tcp --dport 22 -m recent \
|
||
--update --seconds 60 --hitcount 4 --rttl --name SSH -j DROP"))))
|
||
|
||
(define firewall-service
|
||
;; The "firewall". Make it a Shepherd service because as an activation
|
||
;; script it might run too early, before the Netfilter modules can be
|
||
;; loaded for some reason.
|
||
(simple-service 'firewall shepherd-root-service-type
|
||
(list (shepherd-service
|
||
(provision '(firewall))
|
||
(requirement '())
|
||
(start #~(lambda ()
|
||
#$start-firewall))
|
||
(respawn? #f)))))
|
||
|
||
|
||
;;;
|
||
;;; Disk space watchdog.
|
||
;;;
|
||
|
||
(define disk-space-check
|
||
;; Check disk space on the store and on the root file system; stop the
|
||
;; 'cuirass' service if disk space is too low.
|
||
(match-lambda
|
||
((low-store low-root)
|
||
(program-file "check-disk-space"
|
||
(with-imported-modules (source-module-closure
|
||
'((gnu services herd)
|
||
(guix build syscalls)))
|
||
#~(begin
|
||
(use-modules (gnu services herd)
|
||
(guix build syscalls))
|
||
|
||
(when (or (< (free-disk-space #$(%store-prefix))
|
||
#$low-store)
|
||
(< (free-disk-space "/")
|
||
#$low-root))
|
||
(format #t "Low disk space, stopping Cuirass!~%")
|
||
(stop-service 'cuirass))))))))
|
||
|
||
(define (disk-space-mcron-jobs thresholds)
|
||
(list #~(job '(next-hour)
|
||
#$(disk-space-check thresholds))))
|
||
|
||
(define disk-space-watchdog-service-type
|
||
(service-type (name 'disk-space-watchdog)
|
||
(extensions
|
||
(list (service-extension mcron-service-type
|
||
disk-space-mcron-jobs)))
|
||
(description "Stop Cuirass when disk space is too low.")))
|
||
|
||
|
||
;;;
|
||
;;; NGINX.
|
||
;;;
|
||
|
||
(define %nginx-config
|
||
;; Our nginx configuration directory. It expects 'guix publish' to be
|
||
;; running on port 3000.
|
||
(computed-file "nginx-config"
|
||
(with-imported-modules '((guix build utils))
|
||
#~(begin
|
||
(use-modules (guix build utils))
|
||
|
||
(mkdir #$output)
|
||
(chdir #$output)
|
||
(symlink #$(local-file "nginx/berlin.conf")
|
||
"berlin.conf")
|
||
(copy-file #$(local-file
|
||
"nginx/bayfront-locations.conf")
|
||
"berlin-locations.conf")
|
||
(substitute* "berlin-locations.conf"
|
||
(("@WWWROOT@")
|
||
#$(local-file "nginx/html/berlin" #:recursive? #t)))))))
|
||
|
||
(define %nginx-cache-activation
|
||
;; Make sure /var/cache/nginx exists on the first run.
|
||
(simple-service 'nginx-/var/cache/nginx
|
||
activation-service-type
|
||
(with-imported-modules '((guix build utils))
|
||
#~(begin
|
||
(use-modules (guix build utils))
|
||
(mkdir-p "/var/cache/nginx")))))
|
||
|
||
(define %nginx-mime-types
|
||
;; Provide /etc/nginx/mime.types (and a bunch of other files.)
|
||
(simple-service 'nginx-mime.types
|
||
etc-service-type
|
||
`(("nginx" ,(file-append nginx "/share/nginx/conf")))))
|
||
|
||
|
||
(define %certbot-job
|
||
;; Attempt to renew the Let's Encrypt certificate twice a week.
|
||
#~(job (lambda (now)
|
||
(next-day-from (next-hour-from now '(3))
|
||
'(2 5)))
|
||
(string-append #$certbot "/bin/certbot renew")))
|
||
|
||
|
||
|
||
(define %default-motd
|
||
(plain-file "motd"
|
||
"Welcome to the Guix build frontend!\n\n"))
|
||
|
||
(define cuirass-without-fiber-tests
|
||
(package
|
||
(inherit cuirass)
|
||
(inputs
|
||
`(("guile-fibers"
|
||
,(package (inherit guile-fibers)
|
||
(arguments
|
||
`(#:tests? #f
|
||
,@(package-arguments guile-fibers)))))
|
||
,@(alist-delete "guile-fibers" (package-inputs cuirass))))))
|
||
|
||
(define KiB (expt 2 10))
|
||
(define MiB (* KiB KiB))
|
||
(define GiB (* MiB KiB))
|
||
(define TiB (* GiB KiB))
|
||
|
||
(define* (frontend-services sysadmins #:key
|
||
(gc-threshold (* 800 GiB))
|
||
nginx-config-file
|
||
(max-jobs 5)
|
||
(cores 4)
|
||
(build-accounts-to-max-jobs-ratio 4)
|
||
(branches '("master" "staging" "core-updates"))
|
||
(systems '("x86_64-linux" "i686-linux"))
|
||
(motd %default-motd)
|
||
(nar-ttl (* 90 24 3600))
|
||
(publish-workers 6))
|
||
"Return the list of services for the build farm frontend."
|
||
(cons* (service mcron-service-type
|
||
(mcron-configuration
|
||
(jobs (cons %certbot-job
|
||
(gc-jobs gc-threshold)))))
|
||
|
||
firewall-service
|
||
|
||
;; The Web service.
|
||
(service guix-publish-service-type
|
||
(guix-publish-configuration
|
||
(port 3000)
|
||
(cache "/var/cache/guix/publish")
|
||
(ttl nar-ttl)
|
||
(compression '(("gzip" 9) ("lzip" 9)))
|
||
(workers publish-workers)))
|
||
|
||
%nginx-mime-types
|
||
%nginx-cache-activation
|
||
|
||
(service cuirass-service-type
|
||
(cuirass-configuration
|
||
(cuirass cuirass-without-fiber-tests)
|
||
(interval (* 5 60))
|
||
(ttl (quotient nar-ttl 2))
|
||
(specifications (cuirass-specs branches systems))))
|
||
|
||
(service openssh-service-type)
|
||
(service sysadmin-service-type sysadmins)
|
||
|
||
(append (if nginx-config-file
|
||
(list (service nginx-service-type
|
||
(nginx-configuration
|
||
(file nginx-config-file))))
|
||
'())
|
||
(modify-services %base-services
|
||
(guix-service-type
|
||
config => (guix-daemon-config
|
||
#:max-jobs max-jobs
|
||
#:cores cores
|
||
#:build-accounts-to-max-jobs-ratio
|
||
build-accounts-to-max-jobs-ratio))
|
||
(login-service-type
|
||
config => (login-configuration
|
||
(inherit config)
|
||
(motd motd)))))))
|
||
|
||
|
||
;;;
|
||
;;; Goggles, for IRC logs at http://logs.guix.gnu.org.
|
||
;;;
|
||
|
||
(define goggles
|
||
;; The 'goggles' executable.
|
||
(program-file "goggles"
|
||
(with-extensions (list guile-xapian)
|
||
#~(begin
|
||
(setvbuf (current-output-port) 'line)
|
||
(setvbuf (current-error-port) 'line)
|
||
(format (current-error-port) "Starting Goggles...~%")
|
||
|
||
(load-compiled
|
||
#$(computed-file
|
||
"goggles.go"
|
||
#~(begin
|
||
(use-modules (system base compile))
|
||
|
||
(compile-file
|
||
#$(local-file "../../goggles.scm")
|
||
#:output-file #$output))))
|
||
(main (command-line))))))
|
||
|
||
(define %goggles-cache-directory
|
||
;; Directory where Goggles stores its Xapian index.
|
||
"/var/cache/logs.xapian")
|
||
|
||
(define %goggles-irc-log-directory
|
||
;; Directory where IRC logs are stored (by a separate znc process).
|
||
"/var/www/.well-known/all-logs")
|
||
|
||
(define %goggles-activation
|
||
(with-imported-modules '((guix build utils))
|
||
#~(begin
|
||
(use-modules (guix build utils))
|
||
(let ((user (getpwnam "goggles")))
|
||
(mkdir-p #$%goggles-cache-directory)
|
||
(chown #$%goggles-cache-directory
|
||
(passwd:uid user) (passwd:gid user))
|
||
|
||
;; FIXME: This is world-writable! TODO: Write a service to start
|
||
;; znc and run it as user "goggles".
|
||
(mkdir-p #$%goggles-irc-log-directory)
|
||
(chmod #$%goggles-irc-log-directory #o777)))))
|
||
|
||
(define (goggles-shepherd-services goggles)
|
||
(with-imported-modules (source-module-closure
|
||
'((gnu build shepherd)
|
||
(gnu system file-systems)))
|
||
(list (shepherd-service
|
||
(provision '(goggles))
|
||
(requirement '(user-processes loopback))
|
||
(documentation "Run Goggles, the web interface for IRC logs.")
|
||
(modules '((gnu build shepherd)
|
||
(gnu system file-systems)))
|
||
(start #~(make-forkexec-constructor/container
|
||
(list #$goggles)
|
||
#:user "goggles" #:group "goggles"
|
||
#:log-file "/var/log/goggles.log"
|
||
#:mappings (list (file-system-mapping
|
||
(source #$%goggles-cache-directory)
|
||
(target source)
|
||
(writable? #t))
|
||
(file-system-mapping
|
||
(source #$%goggles-irc-log-directory)
|
||
(target source)
|
||
(writable? #f)))
|
||
|
||
;; Run in a UTF-8 locale for proper rendering of the
|
||
;; logs.
|
||
#:environment-variables
|
||
(list (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales
|
||
"/lib/locale")
|
||
"LC_ALL=en_US.utf8")))
|
||
(stop #~(make-kill-destructor))))))
|
||
|
||
(define (goggles-mcron-jobs goggles)
|
||
"Return mcron jobs to update the Xapian indexes by invoking GOGGLES."
|
||
(list #~(job '(next-minute '(0))
|
||
(string-append #$goggles " index")
|
||
#:user "goggles")))
|
||
|
||
(define %goggles-accounts
|
||
(list (user-account
|
||
(name "goggles")
|
||
(group "goggles")
|
||
(home-directory "/var/empty")
|
||
(create-home-directory? #f)
|
||
(shell (file-append shadow "/sbin/nologin"))
|
||
(comment "The Goggles web interface")
|
||
(system? #t))
|
||
(user-group
|
||
(name "goggles")
|
||
(system? #t))))
|
||
|
||
(define %goggles-log-rotations
|
||
(list (log-rotation
|
||
(files (list "/var/log/goggles.log")))))
|
||
|
||
(define goggles-service-type
|
||
(service-type
|
||
(name 'goggles)
|
||
(extensions (list (service-extension account-service-type
|
||
(const %goggles-accounts))
|
||
(service-extension activation-service-type
|
||
(const %goggles-activation))
|
||
(service-extension mcron-service-type
|
||
goggles-mcron-jobs)
|
||
(service-extension rottlog-service-type
|
||
(const %goggles-log-rotations))
|
||
(service-extension shepherd-root-service-type
|
||
goggles-shepherd-services)))
|
||
(default-value goggles)
|
||
(description "Run Goggles, the IRC log web interface.")))
|