maintenance/hydra/modules/sysadmin/services.scm

;;; GNU Guix system administration tools.
;;;
;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018 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 (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 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)
  #:export (firewall-service
            frontend-services))

(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"
                #~(begin
                    (use-modules (ice-9 ftw))

                    (define %roots-directory
                      "/var/guix/profiles/per-user/cuirass/cuirass")

                    (define now
                      (current-time))

                    (define (old? stat)
                      (< (stat:mtime stat)
                         (- now (* 7 3600 24))))

                    (define (handle-gc-root file stat _)
                      (when (and (string-suffix? "-disk-image" file)
                                 (old? stat))
                        (catch 'system-error
                          (lambda ()
                            (delete-file file))
                          (lambda args
                            (pk 'failed-to-delete file
                                (system-error-errno args))))))

                    ;; Note: 'scandir' would introduce too much overhead due
                    ;; to the large number of entries that it would sort.
                    (file-system-fold (const #t)  ;enter?
                                      handle-gc-root
                                      (const #t)  ;down
                                      (const #t)  ;up
                                      (const #t)  ;skip
                                      (const #t)  ;error
                                      #t
                                      %roots-directory
                                      lstat))))

(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 -F80G"))

        ;; Half a day later, make sure half of our quota is available.
        #~(job '(next-hour '(16))
               (string-append #$guix "/bin/guix gc -F40G"))))

(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 (* 2 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* (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 rottlog-service-type (rottlog-configuration))
         (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
                   (interval (* 5 60))
                   (ttl (quotient nar-ttl 3))
                   (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)))))))