mirror of
git://git.savannah.gnu.org/guix/maintenance.git
synced 2023-12-14 03:33:04 +01:00
4eca21f4bd
* hydra/modules/sysadmin/services.scm (%gc-jobs): Rename to... (gc-jobs): ... this, and add a 'threshold' parameter. (KiB, MiB, GiB, TiB): New variables. (frontend-services): Add #:gc-threshold and pass it to 'gc-jobs'. * hydra/berlin.scm (services): Pass #:gc-threshold.
409 lines
16 KiB
Scheme
409 lines
16 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 (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 (guix packages)
|
||
#:use-module (gnu packages)
|
||
#: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
|
||
frontend-services
|
||
KiB MiB GiB TiB))
|
||
|
||
(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? "-qemu-image" file)
|
||
(string-suffix? ".squashfs" file)
|
||
(string-suffix? "docker-pack.tar.gz" file)
|
||
(string-suffix? "docker-image.tar.gz" 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 systems)
|
||
"Return the Cuirass specifications to build Guix for the given SYSTEMS."
|
||
#~(list `((#: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"))))
|
||
`((#: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"))))
|
||
`((#: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"))))
|
||
`((#: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"))))))
|
||
|
||
|
||
;;;
|
||
;;; 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)))))
|
||
|
||
|
||
;;;
|
||
;;; 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)
|
||
(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 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)))))))
|