;;; GNU Guix system administration tools.
;;;
;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2018, 2020, 2022 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2022 Leo Famulari <leo@famulari.name>
;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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 git-download)
  #:use-module (guix modules)
  #:use-module (guix records)
  #:use-module ((guix self) #:select (make-config.scm))
  #:use-module ((guix store) #:select (%store-prefix))
  #:use-module (guix least-authority)
  #: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 vpn)
  #:use-module (gnu services web)
  #:use-module ((gnu system file-systems) #:select (file-system-mapping))
  #:use-module ((gnu build linux-container) #:select (%namespaces))
  #: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)
  #: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 (sysadmin packages)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (firewall-service
            berlin-wireguard-peer
            disk-space-watchdog-service-type
            cuirass-service
            frontend-services
            KiB MiB GiB TiB
            disarchive-configuration
            disarchive-service-type
            goggles-service-type
            goggles-bot-service-type
            goggles-bot-configuration
            crash-dump-service-type

            qa-frontpage-configuration
            qa-frontpage-configuration?
            qa-frontpage-configuration-package
            qa-frontpage-configuration-port
            qa-frontpage-configuration-host
            qa-frontpage-configuration-database
            qa-frontpage-configuration-submit-builds?
            qa-frontpage-configuration-manage-patch-branches?

            qa-frontpage-service-type

            guix-packages-website-configuration
            guix-packages-website-configuration?
            guix-packages-website-configuration-origin
            guix-packages-website-configuration-port
            guix-packages-website-configuration-host

            guix-packages-website-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 (* 2 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" file)
                          (string-suffix? "-iso-image-installer" file)
                          (string-suffix? "-qemu-image" file)
                          (string-suffix? "-image-dir" 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? ".qcow2" 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.  The garbage collection
jobs are run twice a day, when the available free space falls below
THRESHOLD.  THRESHOLD can be set to #f to run a daily full garbage
collection instead."
  (define (make-guix-gc-command threshold)
    `(,(file-append guix "/bin/guix")  "gc"
      ,@(if threshold
            (list "-F" (number->string threshold))
            '())))

  `(,#~(job '(next-hour '(3 15))
            #$cleanup-cuirass-roots)

    ,#~(job '(next-hour '(4))
            (string-join '#$(make-guix-gc-command threshold)))

    ;; Half a day later, make sure half of our quota is available.
    ,@(if threshold
          (list #~(job '(next-hour '(16))
                       (string-join '#$(make-guix-gc-command
                                        (quotient threshold 2)))))
          '())))

(define* (guix-daemon-config #:key (max-jobs 5) (cores 4)
                             (build-accounts-to-max-jobs-ratio 4)
                             (authorized-keys '()))
  (guix-configuration
   (substitute-urls '())
   (authorized-keys 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)
                        "--gc-keep-outputs" "--gc-keep-derivations"))))


;;;
;;; Cuirass.
;;;

(define (images-outputs jobs)
  (map (lambda (job)
         `(build-output
           (job ,job)
           (type "image")
           (path "")))
       jobs))

(define (cuirass-notifications)
  #~(list (email
           (from "cuirass@gnu.org")
           (to "guix-ci@gnu.org")
           (server "sendmail:///var/cuirass/cuirass-mailer"))))

(define (cuirass-specs branches systems)
  "Return the Cuirass specifications to build Guix for the given SYSTEMS."
  #~(list
     #$@(if (member "master" branches)
            #~((specification
                (name "guix")
                (build 'guix)
                (notifications #$(cuirass-notifications))
                (priority 1)
                ;; All the supported architecture should go here but as some
                ;; are quite unstable, focus on the well supported ones here.
                (systems '("x86_64-linux" "i686-linux")))
               (specification
                (name "guix-other-archs")
                (build 'guix)
                (notifications #$(cuirass-notifications))
                (priority 1)
                ;; Restore armhf-linux when it is fixed.
                (systems '("aarch64-linux" "powerpc64le-linux")))
               (specification
                (name "master")
                (build 'all)
                (notifications #$(cuirass-notifications))
                (priority 2)
                (systems '#$systems))
               (specification
                (name "images")
                (build 'images)
                (build-outputs
                 (list
                  (build-output
                   (job "iso9660-image*")
                   (type "ISO-9660")
                   (path ""))
                  #$@(images-outputs
                      (list
                       "hurd-barebones.qcow2"
                       "pine64-barebones-raw-image"
                       "pinebook-pro-barebones-raw-image"))))
                (notifications #$(cuirass-notifications))
                (period 86400)
                (priority 2)
                (systems '#$systems))
               (specification
                (name "tarball")
                (build 'tarball)
                (build-outputs
                 (list
                  (build-output
                   (job "binary-tarball*")
                   (type "archive")
                   (path ""))))
                (notifications #$(cuirass-notifications))
                (period 86400)
                (priority 2)
                (systems '#$systems))
               (specification
                (name "tests")
                (build 'system-tests)
                (notifications #$(cuirass-notifications))
                (period 86400)
                (priority 2)
                (systems '("x86_64-linux")))
               (specification
                (name "source")
                (build '(manifests "etc/source-manifest.scm"))
                (period 7200)
                (priority 3)
                (systems '("x86_64-linux")))
               (specification
                (name "disarchive")
                (build '(manifests "etc/disarchive-manifest.scm"))
                (build-outputs
                 (list (build-output
                        (job "disarchive-collection")
                        (type "archive")
                        (path ""))))
                (period (* 12 3600))
                (priority 2)
                (systems '("x86_64-linux")))
               (specification
                (name "time-travel")
                (build '(manifests "etc/time-travel-manifest.scm"))
                (period (* 12 3600))
                (priority 2)
                (systems '("x86_64-linux" "i686-linux")))
              (specification
                (name "go-team")
                (build 'all)
                (channels
                 (list (channel
                        (inherit %default-guix-channel)
                        (branch "wip-go-updates"))))
                (priority 4)
                (systems '#$systems))
              (specification
                (name "rust-team")
                (build 'all)
                (channels
                 (list (channel
                        (inherit %default-guix-channel)
                        (branch "rust-team"))))
                (priority 4)
                (systems '#$systems)))
            #~())
     #$@(if (member "staging" branches)
            #~((specification
                (name "staging")
                (build 'all)
                (channels
                 (list (channel
                        (inherit %default-guix-channel)
                        (branch "staging"))))
                (priority 3)
                (systems '#$systems)))
            #~())
     #$@(if (member "core-updates" branches)
            #~((specification
                (name "core-updates")
                (build 'core)
                (channels
                 (list (channel
                        (inherit %default-guix-channel)
                        (branch "core-updates"))))
                (priority 4)
                (systems '#$systems)))
            #~())
     #$@(if (member "kernel-updates" branches)
            #~((specification
                (name "kernel-updates")
                (build '(manifests "etc/kernels-manifest.scm"))
                (channels
                 (list (channel
                        (inherit %default-guix-channel)
                        (branch "kernel-updates"))))
                (period 7200)
                (priority 2)
                (systems '#$systems))
               (specification
                (name "kernel-updates-system-tests")
                (build 'system-tests)
                (channels
                 (list (channel
                        (inherit %default-guix-channel)
                        (branch "kernel-updates"))))
                (period 7200)
                (priority 2)
                (systems '("x86_64-linux"))))
            #~())

     ;; Bonus specs: projects other than Guix.

     (specification
      (name 'guile)
      (build '(manifests "build-aux/manifest.scm"))
      (channels
       (list (channel
              (name 'guile)
              (url "https://git.savannah.gnu.org/git/guile.git")
              (branch "main"))
             %default-guix-channel))
      (priority 5)
      (systems '#$systems))))

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


;;;
;;; Wireguard VPN.
;;;

(define berlin-wireguard-peer
  (wireguard-peer
   (name "peer")
   (endpoint "ci.guix.gnu.org:51820")
   (public-key "wOIfhHqQ+JQmskRS2qSvNRgZGh33UxFDi8uuSXOltF0=")
   (allowed-ips '("10.0.0.1/32"))
   (keep-alive 25)))

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


;;;
;;; Populating the Disarchive database.
;;;

(define-record-type* <disarchive-configuration>
  disarchive-configuration make-disarchive-configuration
  disarchive-configuration?
  (cuirass-url   disarchive-configuration-cuirass-url
                 (default "https://ci.guix.gnu.org"))
  (directory     disarchive-configuration-directory
                 (default "/var/cache/disarchive")))

(define disarchive-accounts
  ;; Account under which the Disarchive mcron job runs.
  (list (user-account
         (name "disarchive")
         (group "disarchive")
         (home-directory "/var/empty")
         (create-home-directory? #f)
         (shell (file-append shadow "/sbin/nologin"))
         (comment "The Disarchive database user.")
         (system? #t))
        (user-group
         (name "disarchive")
         (system? #t))))

(define (disarchive-activation config)
  "Create the directory where the Disarchive database is to be stored."
  (let ((directory (disarchive-configuration-directory config)))
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))
          (mkdir-p #$directory)
          (let ((pw (getpw "disarchive")))
            (chown #$directory
                   (passwd:uid pw) (passwd:gid pw)))))))

(define (disarchive-mcron-jobs config)
  (define program
    ;; Run 'sync-disarchive-db.scm'; the version of Guix used here doesn't
    ;; matter since only core interfaces are used.
    (program-file "populate-disarchive-database"
                  #~(system* #$(file-append guix "/bin/guix")
                             "repl" "--"
                             #$(local-file "../../sync-disarchive-db.scm")
                             #$(disarchive-configuration-directory config)
                             #$(disarchive-configuration-cuirass-url config))))

  (list #~(job '(next-hour '(23)) #$program
               #:user "disarchive")))

(define disarchive-service-type
  (service-type
   (name 'disarchive)
   (extensions (list (service-extension mcron-service-type
                                        disarchive-mcron-jobs)
                     (service-extension activation-service-type
                                        disarchive-activation)
                     (service-extension account-service-type
                                        (const disarchive-accounts))))
   (description
    "Periodically copy the latest Disarchive metadata obtained from Cuirass
to a selected directory.")
   (default-value (disarchive-configuration))))


;;;
;;; 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 "30 0 * * 2,5"
         (string-append #$certbot "/bin/certbot renew \
--webroot --webroot-path /var/www")))



(define %default-motd
  (plain-file "motd"
              "Welcome to the Guix build frontend!\n\n"))

(define KiB (expt 2 10))
(define MiB (* KiB KiB))
(define GiB (* MiB KiB))
(define TiB (* GiB KiB))

(define* (cuirass-service #:key branches systems nar-ttl)
  (service cuirass-service-type
           (cuirass-configuration
            (interval (* 5 60))
            (remote-server (cuirass-remote-server-configuration
                            (publish? #f)
                            (trigger-url "http://127.0.0.1")))
            (specifications (cuirass-specs branches systems))
            (parameters "/etc/cuirass.scm"))))

(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"
                                        "kernel-updates"))
                            (systems '("x86_64-linux" "i686-linux"))
                            (authorized-keys authorized-keys)
                            (motd %default-motd)
                            (nar-ttl (* 180 24 3600))
                            (cache-bypass-threshold (* 100 (expt 2 20))) ;100 MiB
                            (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)
                   ;; See
                   ;; <https://lists.gnu.org/archive/html/guix-devel/2021-01/msg00097.html>
                   ;; for the compression ratio/decompression speed
                   ;; tradeoffs.
                   (compression '(("lzip" 9) ("zstd" 19)))
                   (cache-bypass-threshold cache-bypass-threshold)
                   (workers publish-workers)))

         %offload-service

         %nginx-mime-types
         %nginx-cache-activation

         (service crash-dump-service-type)
         (cuirass-service #:branches branches
                          #:systems systems
                          #:nar-ttl nar-ttl)

         (service openssh-service-type
                  (openssh-configuration
                   (password-authentication? #f)))
         (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
                               #:authorized-keys authorized-keys
                               #: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 guile-lib)
                  #~(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 goggles-bot.  The
  ;; directory is created as part of goggles-bot-activation.
  "/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))))))

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


;;;
;;; Logging IRC channels with goggles-bot.
;;;

(define-record-type* <goggles-bot-configuration>
  goggles-bot-configuration make-goggles-bot-configuration
  goggles-bot-configuration?
  (channels       goggles-bot-configuration-channels
                  (default '("#guix")))
  (log-directory  goggles-bot-configuration-log-directory
                  (default %goggles-irc-log-directory)))

(define goggles-bot-program
  (with-extensions (list guile-irc guile-gnutls)
    (program-file "goggles-bot"
                  #~(load #$(local-file "../../goggles-bot.scm")))))

(define (goggles-bot-shepherd-services config)
  (define channels
    (goggles-bot-configuration-channels config))

  (define log-directory
    (goggles-bot-configuration-log-directory config))

  (define program/wrapped
    (least-authority-wrapper
     goggles-bot-program
     #:name "goggles-bot"
     #:mappings (list (file-system-mapping
                       (source log-directory)
                       (target log-directory)
                       (writable? #t))
                      (file-system-mapping
                       (source (file-append glibc-utf8-locales "/lib/locale"))
                       (target "/run/current-system/locale")))
     #:namespaces (delq 'net %namespaces)
     #:preserved-environment-variables '("GUIX_LOCPATH" "LC_ALL")))

  (list (shepherd-service
         (provision '(goggles-bot))
         (requirement '(user-processes networking))
         (start #~(make-forkexec-constructor
                   (list #$program/wrapped
                         #$(string-append "--directory=" log-directory)
                         #$@(map (lambda (channel)
                                   (string-append "--channel=" channel))
                                 channels))
                   #:user "goggles-bot" #:group "goggles-bot"
                   #:log-file "/var/log/goggles-bot.log"
                   #:environment-variables
                   (list "GUIX_LOCPATH=/run/current-system/locale"
                         "LC_ALL=en_US.utf8")))
         (stop #~(make-kill-destructor))
         (documentation "Run Goggles-Bot, the IRC logging robot."))))

(define %goggles-bot-accounts
  (list (user-account
         (name "goggles-bot")
         (group "goggles-bot")
         (home-directory "/var/empty")
         (create-home-directory? #f)
         (shell (file-append shadow "/sbin/nologin"))
         (comment "The Goggles IRC logging robot.")
         (system? #t))
        (user-group
         (name "goggles-bot")
         (system? #t))))

(define %goggles-bot-log-rotations
  (list (log-rotation
         (files (list "/var/log/goggles-bot.log")))))

(define (goggles-bot-activation config)
  (let ((log-directory (goggles-bot-configuration-log-directory config)))
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))
          (let ((user (getpwnam "goggles-bot")))
            (mkdir-p #$log-directory)
            (chown #$log-directory
                   (passwd:uid user) (passwd:gid user))
            (chmod #$log-directory #o755))))))

(define goggles-bot-service-type
  (service-type
   (name 'goggles-bot)
   (extensions (list (service-extension account-service-type
                                        (const %goggles-bot-accounts))
                     (service-extension activation-service-type
                                        goggles-bot-activation)
                     (service-extension rottlog-service-type
                                        (const %goggles-bot-log-rotations))
                     (service-extension shepherd-root-service-type
                                        goggles-bot-shepherd-services)))
   (default-value (goggles-bot-configuration))
   (description "Run Goggles-Bot, the IRC logging robot.")))


;;;
;;; Crash-dump.
;;;

(define %crash-dump-cache-directory
  ;; Directory where Crash-dump stores the reports.
  "/var/cache/crash-dump")

(define %crash-dump-activation
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))
        (let ((user (getpwnam "crash-dump")))
          (mkdir-p #$%crash-dump-cache-directory)
          (chown #$%crash-dump-cache-directory
                 (passwd:uid user) (passwd:gid user))))))

(define crash-dump
  (program-file "crash-dump"
                (with-extensions (list guile-gcrypt guile-webutils
                                       guile-json-4)
                  #~(begin
                      (setvbuf (current-output-port) 'line)
                      (setvbuf (current-error-port) 'line)
                      (format (current-error-port) "Starting crash-dump...~%")

                      (load-compiled
                       #$(computed-file
                          "crash-dump.go"
                          #~(begin
                              (use-modules (system base compile))

                              (compile-file
                               #$(local-file "../../crash-dump.scm")
                               #:output-file #$output))))
                      (crash-dump '("_"
                                    "-p" "2121"
                                    "-o" #$%crash-dump-cache-directory))))))

(define (crash-dump-shepherd-services crash-dump)
  (with-imported-modules (source-module-closure
                          '((gnu build shepherd)
                            (gnu system file-systems)))
    (list (shepherd-service
           (provision '(crash-dump))
           (requirement '(user-processes loopback))
           (documentation "Run Crash-dump.")
           (modules '((gnu build shepherd)
                      (gnu system file-systems)))
           (start #~(make-forkexec-constructor/container
                     (list #$crash-dump)
                     #:user "crash-dump" #:group "crash-dump"
                     #:log-file "/var/log/crash-dump.log"
                     #:mappings (list (file-system-mapping
                                       (source #$%crash-dump-cache-directory)
                                       (target source)
                                       (writable? #t)))
                     ;; 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 %crash-dump-accounts
  (list (user-account
         (name "crash-dump")
         (group "crash-dump")
         (home-directory "/var/empty")
         (create-home-directory? #f)
         (shell (file-append shadow "/sbin/nologin"))
         (comment "The Crash-dump web server")
         (system? #t))
        (user-group
         (name "crash-dump")
         (system? #t))))

(define %crash-dump-log-rotations
  (list (log-rotation
         (files (list "/var/log/crash-dump.log")))))

(define crash-dump-service-type
  (service-type
   (name 'crash-dump)
   (extensions (list (service-extension account-service-type
                                        (const %crash-dump-accounts))
                     (service-extension activation-service-type
                                        (const %crash-dump-activation))
                     (service-extension rottlog-service-type
                                        (const %crash-dump-log-rotations))
                     (service-extension shepherd-root-service-type
                                        crash-dump-shepherd-services)))
   (default-value crash-dump)
   (description "Run a crash dump HTTP web server.")))


;;;
;;; Offloading
;;;

(define %offload-service
  ;; Provide /etc/guix/machines.scm file.
  (simple-service
   'guix-machines.scm
   activation-service-type
   (with-imported-modules '((guix build utils))
     #~(begin
         (use-modules (guix build utils))
         (if (file-exists? "/etc/guix/machines.scm")
             (if (and (symbolic-link? "/etc/guix/machines.scm")
                      (store-file-name? (readlink "/etc/guix/machines.scm")))
                 (delete-file "/etc/guix/machines.scm")
                 (rename-file "/etc/guix/machines.scm"
                              "/etc/guix/machines.scm.bak"))
             (mkdir-p "/etc/guix"))

         ;; Install the machines file.
         (symlink #$(local-file "../../machines-for-berlin.scm")
                  "/etc/guix/machines.scm")))))


;;;
;;; QA Frontpage
;;;

(define-record-type* <qa-frontpage-configuration>
  qa-frontpage-configuration make-qa-frontpage-configuration
  qa-frontpage-configuration?
  (package        qa-frontpage-configuration-package
                  (default qa-frontpage))
  (port           qa-frontpage-configuration-port
                  (default 8765))
  (host           qa-frontpage-configuration-host
                  (default "127.0.0.1"))
  (database       qa-frontpage-configuration-database
                  (default "/var/lib/qa-frontpage/guix_qa_frontpage.db"))
  (submit-builds? qa-frontpage-configuration-submit-builds?
                  (default #f))
  (manage-patch-branches?
   qa-frontpage-configuration-manage-patch-branches?
   (default #f)))

(define (qa-frontpage-shepherd-services config)
  (match-record config <qa-frontpage-configuration>
    (package port host database submit-builds? manage-patch-branches?)

    (define log-directory "/var/log/qa-frontpage")

    (define program/wrapped
      (least-authority-wrapper
       (file-append package "/bin/guix-qa-frontpage")
       #:name "qa-frontpage"
       #:mappings (list (file-system-mapping
                         (source log-directory)
                         (target log-directory)
                         (writable? #t))
                        (file-system-mapping
                         (source "/var/lib/qa-frontpage")
                         (target source)
                         (writable? #t))
                        (file-system-mapping
                         (source "/etc/ssl/certs")
                         (target source))
                        (file-system-mapping
                         (source "/gnu/store")
                         (target source))
                        (file-system-mapping
                         (source (file-append glibc-utf8-locales "/lib/locale"))
                         (target "/run/current-system/locale")))
       #:directory "/var/lib/qa-frontpage"
       #:namespaces (delq 'net %namespaces)
       #:preserved-environment-variables '("GUIX_LOCPATH" "LC_ALL" "HOME"
                                           "GIT_SSL_CAINFO"
                                           "SSL_CERT_DIR" "SSL_CERT_FILE")))

    (list (shepherd-service
           (provision '(qa-frontpage))
           (requirement '(user-processes networking))
           (start #~(make-forkexec-constructor
                     (list
                      ;; TODO: SSH has problems with the least authority wrapper
                      ;; git fetch --prune patches
                      ;; No user exists for uid 1000
                      ;; #$program/wrapped
                      #$(file-append package "/bin/guix-qa-frontpage")
                      #$@(if port
                             #~(#$(simple-format #f "--port=~A" port))
                             '())
                      #$@(if host
                             #~(#$(string-append "--host=" host))
                             '())
                      #$@(if database
                             #~(#$(string-append "--database=" database))
                             '())
                      #$@(if submit-builds?
                             '("--submit-builds")
                             '())
                      #$@(if manage-patch-branches?
                             '("--manage-patch-branches")
                             '()))
                     #:user "qa-frontpage" #:group "qa-frontpage"
                     #:log-file "/var/log/qa-frontpage/main.log"
                     #:directory "/var/lib/qa-frontpage"
                     #:environment-variables
                     (list "GUIX_LOCPATH=/run/current-system/locale"
                           "LC_ALL=en_US.utf8"
                           "HOME=/var/lib/qa-frontpage"
                           "GIT_SSL_CAINFO=/etc/ssl/certs/ca-certificates.crt"
                           "SSL_CERT_DIR=/etc/ssl/certs"
                           "SSL_CERT_FILE=/etc/ssl/certs/ca-certificates.crt")))
           (stop #~(make-kill-destructor))
           (documentation "Run the QA Frontpage.")))))

(define %qa-frontpage-accounts
  (list (user-account
         (name "qa-frontpage")
         (group "qa-frontpage")
         (home-directory "/var/lib/qa-frontpage")
         (shell (file-append shadow "/sbin/nologin"))
         (comment "The QA Frontpage.")
         (system? #t))
        (user-group
         (name "qa-frontpage")
         (system? #t))))

(define qa-frontpage-service-type
  (service-type
   (name 'qa-frontpage)
   (extensions (list (service-extension account-service-type
                                        (const %qa-frontpage-accounts))
                     (service-extension shepherd-root-service-type
                                        qa-frontpage-shepherd-services)))
   (default-value (qa-frontpage-configuration))
   (description "Run the QA frontpage.")))


;;;
;;; packages.guix.gnu.org
;;;

(define-record-type* <guix-packages-website-configuration>
  guix-packages-website-configuration make-guix-packages-website-configuration
  guix-packages-website-configuration?
  (origin         guix-packages-website-configuration-origin
                  (default
                    (let* ((commit "72817057c0ba86663ae0a29bde13c15b686600d0")
                          (version (git-version "0" "0" commit)))
                      (origin
                        (method git-fetch)
                        (uri (git-reference
                              (url "https://codeberg.org/luis-felipe/guix-packages-website.git")
                              (commit commit)))
                        (file-name (git-file-name "guix-packages-website" version))
                        (sha256
                         (base32
                          "0jm0aipdw97sb1lwzczgwzacv9jgyippgq79na87647lqapq8fcx"))
                        (modules '((guix build utils)))
                        (snippet
                         '(begin
                            (use-modules (guix build utils))

                            ;; TODO This seemed to be needed to avoid
                            ;; `path` being undefined when Guile tries
                            ;; to load urls.scm
                            (substitute* "gweb/urls.scm"
                              (("define MANUAL_URL .*$")
                               "define MANUAL_URL \"https://www.gnu.org/software/guix/manual\")\n"))))))))
  (port           guix-packages-website-configuration-port
                  (default 3000))
  (host           guix-packages-website-configuration-host
                  (default "127.0.0.1")))

(define (guix-packages-website-shepherd-services config)
  (match-record config <guix-packages-website-configuration>
    (origin port host)

    (define program/wrapped
      (least-authority-wrapper
       (program-file
        "wrapped-art"
        (with-extensions (list artanis guile-json-4)
          #~(begin
              (use-modules (srfi srfi-1))
              (let ((script
                     #$(file-append artanis "/bin/art")))
                (for-each
                 (lambda (var lst)
                   (setenv var
                           (string-join
                            (append (take lst 2)
                                    (or (and=> (getenv var)
                                               list)
                                        '()))
                            ":")))
                 '("GUILE_LOAD_PATH"
                   "GUILE_LOAD_COMPILED_PATH")
                 (list %load-path
                       %load-compiled-path))
                (setenv "GUILE_LOAD_PATH"
                        (string-append
                         #$origin ":" (getenv "GUILE_LOAD_PATH")))
                (apply execl
                       script
                       script
                       (cdr (command-line)))))))
       #:name "wrapped-art-for-guix-packages-website"

       ;; TODO I think this approach might be OK, but it's pretty
       ;; terrible at the moment. Artanis seems to require deleting
       ;; and re-creating the .route file at the top level of the
       ;; project directory upon startup, which means that you can't
       ;; just bind mount the source code as read only, then bind
       ;; mount specific directories as read write.
       ;;
       ;; To get around that, specific files and directories in the
       ;; source are bind mounted in to
       ;; /var/lib/guix-packages-website, but that's quite fragile.
       #:mappings (cons* (file-system-mapping
                          (source "/var/lib/guix-packages-website")
                          (target source)
                          (writable? #t))
                         (file-system-mapping
                          (source "/var/cache/guix-packages-website")
                          (target "/var/lib/guix-packages-website/tmp/cache")
                          (writable? #t))
                         (file-system-mapping
                          (source (file-append glibc-utf8-locales "/lib/locale"))
                          (target "/run/current-system/locale"))
                         (map (lambda (file)
                                (file-system-mapping
                                 (source (file-append origin (string-append "/" file)))
                                 (target (string-append "/var/lib/guix-packages-website/" file))))
                              '("conf" "ENTRY" "gweb" "icon.svg" "pub")))
       #:directory "/var/lib/guix-packages-website"
       #:namespaces (delq 'net %namespaces)
       #:preserved-environment-variables '("GUIX_LOCPATH" "LC_ALL" "HOME")))

    (list (shepherd-service
           (provision '(guix-packages-website))
           (requirement '(user-processes networking))
           (start #~(make-forkexec-constructor
                     (list #$program/wrapped
                           "work"
                           #$@(if port
                                  #~(#$(simple-format #f "--port=~A" port))
                                  '())
                           #$@(if host
                                  #~(#$(string-append "--host=" host))
                                  '()))
                     #:user "guix-packages-website" #:group "guix-packages-website"
                     #:log-file "/var/log/guix-packages-website.log"
                     #:directory "/var/lib/guix-packages-website"
                     #:environment-variables
                     (list "GUIX_LOCPATH=/run/current-system/locale"
                           "LC_ALL=en_US.utf8"
                           "HOME=/var/lib/guix-packages-website")))
           (stop #~(make-kill-destructor))
           (documentation "Run the Guix Packages website.")))))

(define (guix-packages-website-activation config)
  (let ((cache-directory "/var/cache/guix-packages-website"))
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils))
          (mkdir-p #$cache-directory)
          (let ((pw (getpw "guix-packages-website")))
            (chown #$cache-directory
                   (passwd:uid pw) (passwd:gid pw)))))))

(define %guix-packages-website-accounts
  (list (user-account
         (name "guix-packages-website")
         (group "guix-packages-website")
         (home-directory "/var/lib/guix-packages-website")
         (shell (file-append shadow "/sbin/nologin"))
         (comment "The Guix Packages website.")
         (system? #t))
        (user-group
         (name "guix-packages-website")
         (system? #t))))

(define guix-packages-website-service-type
  (service-type
   (name 'guix-packages-website)
   (extensions (list (service-extension account-service-type
                                        (const %guix-packages-website-accounts))
                     (service-extension activation-service-type
                                        guix-packages-website-activation)
                     (service-extension shepherd-root-service-type
                                        guix-packages-website-shepherd-services)))
   (default-value (guix-packages-website-configuration))
   (description "Run the Guix Packages website.")))