;;; GNU Guix system administration tools. ;;; ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2017, 2018, 2020 Ricardo Wurmus ;;; ;;; 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 . (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)) (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? "-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 ;; The garbage collection mcron jobs. (list #~(job '(next-hour '(3)) #$cleanup-cuirass-roots) #~(job '(next-hour '(4)) (string-append #$guix "/bin/guix gc -F800G")) ;; Half a day later, make sure half of our quota is available. #~(job '(next-hour '(16)) (string-append #$guix "/bin/guix gc -F400G")))) (define* (guix-daemon-config #:key (max-jobs 5) (cores 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 (* 4 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 ;; . #~(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* (frontend-services sysadmins #:key nginx-config-file (max-jobs 5) (cores 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)))) 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)) (login-service-type config => (login-configuration (inherit config) (motd motd)))))))