(define-module (org euandre services)
#:use-module ((org euandre packages) #:prefix pkg:)
#:use-module ((org euandre queue) #:prefix q:)
#:use-module ((ice-9 match) #:prefix m:)
#:use-module ((ice-9 popen) #:prefix popen:)
#:use-module ((ice-9 textual-ports) #:prefix textual-ports:)
#:use-module ((gnu build linux-container) #:prefix container:)
#:use-module ((srfi srfi-1) #:prefix s1:)
#:use-module ((xyz euandreh heredoc) #:prefix heredoc:)
#:use-module (gnu)
#:use-module (guix build utils)
#:use-module (guix least-authority)
#:use-module (guix records)
#:export (<syskeep-configuration>
syskeep-configuration
make-syskeep-configuration
syskeep-configuration?
syskeep-configuration-package
syskeep-configuration-log-file
<binder-configuration>
binder-configuration
make-binder-configuration
binder-configuration?
binder-configuration-name
binder-configuration-package
binder-configuration-user
binder-configuration-group
binder-configuration-log-file
binder-configuration-data-directory
binder-configuration-run-directory
binder-configuration-run-in-container?
binder-configuration-container-name
binder-configuration-extra-mappings
<glaze-configuration>
glaze-configuration
make-glaze-configuration
glaze-configuration?
glaze-configuration-name
glaze-configuration-package
glaze-configuration-user
glaze-configuration-group
glaze-configuration-log-file
glaze-configuration-data-directory
glaze-configuration-run-directory
glaze-configuration-run-in-container?
glaze-configuration-container-name
glaze-configuration-extra-mappings
<untls-configuration>
untls-configuration
make-untls-configuration
untls-configuration?
untls-configuration-name
untls-configuration-package
untls-configuration-user
untls-configuration-group
untls-configuration-log-file
untls-configuration-data-directory
untls-configuration-run-directory
untls-configuration-run-in-container?
untls-configuration-container-name
untls-configuration-extra-mappings
<wscat-configuration>
wscat-configuration
make-wscat-configuration
wscat-configuration?
wscat-configuration-name
wscat-configuration-package
wscat-configuration-user
wscat-configuration-group
wscat-configuration-log-file
wscat-configuration-data-directory
wscat-configuration-run-directory
wscat-configuration-run-in-container?
wscat-configuration-container-name
wscat-configuration-extra-mappings
<papod-configuration>
papod-configuration
make-papod-configuration
papod-configuration?
papod-configuration-name
papod-configuration-package
papod-configuration-user
papod-configuration-group
papod-configuration-log-file
papod-configuration-data-directory
papod-configuration-run-directory
papod-configuration-run-in-container?
papod-configuration-container-name
papod-configuration-extra-mappings))
(use-package-modules
admin
version-control)
(use-service-modules
admin
mcron
shepherd)
(define-public (slurp path)
(call-with-input-file
path
textual-ports:get-string-all))
(define-public (str . rest)
(apply string-append rest))
(define-public (fmt . rest)
(apply format #f rest))
(define-public (user-accounts users)
(map (lambda (user)
(let ((name (s1:first user))
(comment (s1:second user))
(groups (s1:third user)))
(user-account
(name name)
(comment comment)
(group "users")
(supplementary-groups groups))))
users))
(define-public (users->keys users)
(let ((users-with-keys (filter (compose not null? cdddr)
users)))
(append
(map (lambda (user)
(let ((name (s1:first user))
(key (s1:fourth user)))
`(,name ,(plain-file (str name "-id_rsa.pub") key))))
users-with-keys)
`(("git" ,@(map (lambda (user)
(let ((name (s1:first user))
(key (s1:fourth user)))
(plain-file (str name "-git-id_rsa.pub")
(slurp key))))
users-with-keys))))))
(define (tuple->entry tuple)
(let* ((name (s1:first tuple))
(package (s1:second tuple))
(path (string-append "/etc/" name)))
(list
name
(computed-file
(string-append "syskeep-" name)
#~(begin
(use-modules
((ice-9 textual-ports) #:prefix textual-ports:))
(define (slurp p)
(call-with-input-file p textual-ports:get-string-all))
(define (spit p s)
(call-with-output-file
p
(lambda (port)
(display s port))))
(spit #$output
(slurp #$(file-append package path))))))))
(define (etc-entries package paths)
(map
tuple->entry
(map (lambda (path)
(list path package))
paths)))
(define-public (package-set symbols records)
(append
records
(map
(compose list specification->package+output symbol->string)
symbols)))
(define-public skeletons
(etc-entries
pkg:syskeep
'(".profile")))
(define-public base-services
(modify-services %base-services
(rottlog-service-type config =>
(rottlog-configuration
(inherit config)
(rc-file
(file-append q:rottlog-mailutils-sendmail "/etc/rc"))))))
(define-record-type* <syskeep-configuration>
syskeep-configuration
make-syskeep-configuration
syskeep-configuration?
(package syskeep-configuration-package (default pkg:syskeep))
(log-file syskeep-configuration-log-file (default "/var/log/cronjobs/cronjobs.log")))
(define (syskeep-profile config)
(match-record config <syskeep-configuration>
(package)
(package-set
'(parted
guile-heredoc
acl
bind:utils
knot:tools
file
git
lsof
moreutils
mailutils-sendmail
curl
make
borg
rsync
sqlite
strace
rlwrap
trash-cli
tree)
(list
package))))
(define (syskeep-rotations config)
(match-record config <syskeep-configuration>
(log-file)
(list
(log-rotation
(frequency 'weekly)
(files (list log-file))
(options '("rotate 52"))))))
(define (syskeep-cronjobs config)
(match-record config <syskeep-configuration>
()
(list
#~(job "0 0 * * *" "cronjob check")
#~(job "0 1 * * *" "cronjob env BORG_REPO=/mnt/backup/borg backup -q cron")
#~(job "0 2 * * *" "cronjob backup -q cron")
#~(job "0 3 * * 0" "cronjob gc")
#~(job "0 4 * * *" "cronjob reconfigure -U"))))
(define (syskeep-etc-files config)
(match-record config <syskeep-configuration>
(package)
(etc-entries
package
'("rc"
"known_hosts"
"ssh.conf"
"init.scm"
"gitconfig"))))
(define (syskeep-accounts config)
(match-record config <syskeep-configuration>
()
(list
(user-account
(name "git")
(group "git")
(system? #t)
(comment "External SSH Git user")
(home-directory "/src/ĝit")
(create-home-directory? #f)
(shell
(file-append git "/bin/git-shell")))
(user-group
(name "git")
(system? #t)))))
(define-public syskeep-service-type
(service-type
(name 'syskeep)
(extensions
(list
(service-extension rottlog-service-type
syskeep-rotations)
(service-extension mcron-service-type
syskeep-cronjobs)
(service-extension etc-service-type
syskeep-etc-files)
(service-extension account-service-type
syskeep-accounts)
(service-extension profile-service-type
syskeep-profile)))
(default-value (syskeep-configuration))
(description "Common configuration of maintained servers.")))
(define-record-type* <binder-configuration>
binder-configuration
make-binder-configuration
binder-configuration?
(name binder-configuration-name (default "binder"))
(package binder-configuration-package (default pkg:binder))
(user binder-configuration-user (default "binder"))
(group binder-configuration-group (default "binder"))
(log-file binder-configuration-log-file (default "/var/log/binder/binder.log"))
(data-directory binder-configuration-data-directory (default #f))
(run-directory binder-configuration-run-directory (default "/var/run/binder"))
(run-in-container? binder-configuration-run-in-container? (default #t))
(container-name binder-configuration-container-name (default "binder-container"))
(extra-mappings binder-configuration-extra-mappings (default '())))
(define-record-type* <glaze-configuration>
glaze-configuration
make-glaze-configuration
glaze-configuration?
(name glaze-configuration-name (default "glaze"))
(package glaze-configuration-package (default pkg:glaze))
(user glaze-configuration-user (default "glaze"))
(group glaze-configuration-group (default "glaze"))
(log-file glaze-configuration-log-file (default "/var/log/glaze/glaze.log"))
(data-directory glaze-configuration-data-directory (default #f))
(run-directory glaze-configuration-run-directory (default "/var/run/glaze"))
(run-in-container? glaze-configuration-run-in-container? (default #t))
(container-name glaze-configuration-container-name (default "glaze-container"))
(extra-mappings glaze-configuration-extra-mappings (default '())))
(define-record-type* <untls-configuration>
untls-configuration
make-untls-configuration
untls-configuration?
(name untls-configuration-name (default "untls"))
(package untls-configuration-package (default pkg:untls))
(user untls-configuration-user (default "untls"))
(group untls-configuration-group (default "untls"))
(log-file untls-configuration-log-file (default "/var/log/untls/untls.log"))
(data-directory untls-configuration-data-directory (default #f))
(run-directory untls-configuration-run-directory (default "/var/run/untls"))
(run-in-container? untls-configuration-run-in-container? (default #t))
(container-name untls-configuration-container-name (default "untls-container"))
(extra-mappings untls-configuration-extra-mappings (default '())))
(define-record-type* <wscat-configuration>
wscat-configuration
make-wscat-configuration
wscat-configuration?
(name wscat-configuration-name (default "wscat"))
(package wscat-configuration-package (default pkg:wscat))
(user wscat-configuration-user (default "wscat"))
(group wscat-configuration-group (default "wscat"))
(log-file wscat-configuration-log-file (default "/var/log/wscat/wscat.log"))
(data-directory wscat-configuration-data-directory (default #f))
(run-directory wscat-configuration-run-directory (default "/var/run/wscat"))
(run-in-container? wscat-configuration-run-in-container? (default #t))
(container-name wscat-configuration-container-name (default "wscat-container"))
(extra-mappings wscat-configuration-extra-mappings (default '())))
(define-record-type* <papod-configuration>
papod-configuration
make-papod-configuration
papod-configuration?
(name papod-configuration-name (default "papod"))
(package papod-configuration-package (default pkg:papod))
(user papod-configuration-user (default "papod"))
(group papod-configuration-group (default "papod"))
(log-file papod-configuration-log-file (default "/var/log/papod/papod.log"))
(data-directory papod-configuration-data-directory (default "/var/lib/papod"))
(run-directory papod-configuration-run-directory (default "/var/run/papod"))
(run-in-container? papod-configuration-run-in-container? (default #t))
(container-name papod-configuration-container-name (default "papod-container"))
(extra-mappings papod-configuration-extra-mappings (default '())))
(define-public (profile-for type)
(lambda (config)
(m:match config
(($ type _name package)
(list package)))))
(define-public (rotations-for type)
(lambda (config)
(m:match config
(($ type _name _package _user _group log-file)
(list
(log-rotation
(frequency 'weekly)
(files (list log-file))
(options '("rotate 5200"))))))))
(define-public (activation-for type)
(lambda (config)
(m:match config
(($ type name _package user _group log-file data-directory run-directory)
#~(begin
(use-modules (guix build utils))
(when #$log-file
(format (current-error-port)
"Creating ~a log directory for '~a'.~%" #$name #$log-file)
(mkdir-p (dirname #$log-file))
(when (not (file-exists? #$log-file))
(call-with-output-file #$log-file (const #t)))
(chmod #$log-file #o644))
(let ((user (getpwnam #$user)))
(when #$data-directory
(format (current-error-port)
"Creating ~a data directory '~a'.~%" #$name #$data-directory)
(mkdir-p #$data-directory)
(chown #$data-directory (passwd:uid user) (passwd:gid user))
(chmod #$data-directory #o750))
(when #$run-directory
(format (current-error-port)
"Creating ~a run directory '~a'.~%" #$name #$run-directory)
(mkdir-p #$run-directory)
(chown #$run-directory (passwd:uid user) (passwd:gid user))
(chmod #$run-directory #o755))))))))
(define-public (accounts-for type)
(lambda (config)
(m:match config
(($ type name _package user group)
(list
(user-group
(name group)
(system? #t))
(user-account
(name user)
(group group)
(system? #t)
(comment (format #f "The user for runtime execution of ~a code" name))
(home-directory "/var/empty")
(shell
(file-append shadow "/sbin/nologin"))))))))
(define-public (shepherd-services-for type)
(lambda (config)
(m:match config
(($ type name package user group log-file data-directory _run-directory run-in-container? container-name extra-mappings)
(list
(shepherd-service
(provision (list (string->symbol name)))
(requirement '())
(start
#~(make-forkexec-constructor ;; FIXME: add #:resource-limits
(list
#$(let ((bin (file-append package (string-append "/bin/" name))))
(if (not run-in-container?)
bin
(least-authority-wrapper
bin
#:user user
#:group group
#:name container-name
#:directory (or data-directory "/")
#:preserved-environment-variables
'()
#:mappings
(append
(if data-directory
(list
(file-system-mapping
(source data-directory)
(target source)
(writable? #t)))
(list))
extra-mappings)))))
#:user #$user
#:group #$group
#:log-file #$log-file
#:directory #$data-directory))
(stop #~(make-kill-destructor SIGKILL))
(documentation
(fmt "The Shepherd service that runs the server via \"~a\"." name))))))))
(define-public (service-type-for name type config extensions)
(service-type
(name name)
(extensions
(append
(list
(service-extension shepherd-root-service-type
(shepherd-services-for type))
(service-extension profile-service-type
(profile-for type))
(service-extension activation-service-type
(activation-for type))
(service-extension account-service-type
(accounts-for type))
(service-extension rottlog-service-type
(rotations-for type)))
extensions))
(default-value config)
(description
(fmt "The top-level generic system service, generated for ~a code.
It includes:
- the Shepherd service for starting, stopping and reloading the service;
- activation script for setting up the initial directories and permissions;
- the group and account for running the production service;
- log management (storage and rotation) for logs produced by the running services.
The default configuration should provide sane values for all of these."
name))))
(define-public binder-service-type
(service-type-for 'binder <binder-configuration> (binder-configuration) '()))
(define-public glaze-service-type
(service-type-for 'glaze <glaze-configuration> (glaze-configuration) '()))
(define-public untls-service-type
(service-type-for 'untls <untls-configuration> (untls-configuration) '()))
(define-public wscat-service-type
(service-type-for 'wscat <wscat-configuration> (wscat-configuration) '()))
(define-public papod-service-type
(service-type-for 'papod <papod-configuration> (papod-configuration) '()))
