1330 lines
52 KiB
Scheme
1330 lines
52 KiB
Scheme
;;; 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.")))
|