maintenance/hydra/modules/sysadmin/services.scm

;;; 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))

(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? "-installed-os" file)
                          (string-suffix? "-installed-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
  ;; <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* (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)))))))