(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 make-syskeep-configuration syskeep-configuration? syskeep-configuration-package syskeep-configuration-log-file 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 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 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 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 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 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 (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 (log-file) (list (log-rotation (frequency 'weekly) (files (list log-file)) (options '("rotate 52")))))) (define (syskeep-cronjobs config) (match-record config () (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 (package) (etc-entries package '("rc" "known_hosts" "ssh.conf" "init.scm" "gitconfig")))) (define (syskeep-accounts config) (match-record config () (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 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 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 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 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 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) '())) (define-public glaze-service-type (service-type-for 'glaze (glaze-configuration) '())) (define-public untls-service-type (service-type-for 'untls (untls-configuration) '())) (define-public wscat-service-type (service-type-for 'wscat (wscat-configuration) '())) (define-public papod-service-type (service-type-for 'papod (papod-configuration) '()))