(define-module (org euandre packages) #:use-module ((guix licenses) #:prefix licenses:) #:use-module ((ice-9 match) #:prefix m:) #:use-module ((ice-9 textual-ports) #:prefix textual-ports:) #:use-module ((org euandre queue) #:prefix q:) #:use-module ((srfi srfi-1) #:prefix s1:) #:use-module (gnu) #:use-module (guix build-system gnu) #:use-module (guix git-download) #:use-module (guix least-authority) #:use-module (guix packages) #:use-module (guix records) #:use-module (guix utils) #:export ( syskeep-configuration make-syskeep-configuration syskeep-configuration? syskeep-configuration-package syskeep-configuration-log-file git-configuration make-git-configuration git-configuration? git-configuration-package git-configuration-user git-configuration-group git-configuration-export-all? git-configuration-base-path git-configuration-user-path git-configuration-run-in-container? git-configuration-container-name 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 binder-configuration-options binder-configuration-listen-socket binder-configuration-upstream-socket 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 glaze-configuration-options glaze-configuration-listen-socket glaze-configuration-upstream-socket hsts-configuration make-hsts-configuration hsts-configuration? hsts-configuration-name hsts-configuration-package hsts-configuration-user hsts-configuration-group hsts-configuration-log-file hsts-configuration-data-directory hsts-configuration-run-directory hsts-configuration-run-in-container? hsts-configuration-container-name hsts-configuration-extra-mappings hsts-configuration-options hsts-configuration-listen-socket hsts-configuration-upstream-socket 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 untls-configuration-options untls-configuration-listen-socket untls-configuration-upstream-socket 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 wscat-configuration-options wscat-configuration-listen-socket wscat-configuration-upstream-socket fmt str service-type-for)) (use-package-modules admin guile texinfo version-control) (use-service-modules admin mcron shepherd sysctl) (define-public (mklist x) (if (not x) '() (if (pair? x) x (list x)))) (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 (pkg name version checksum) (package (name name) (version version) (source (origin (method git-fetch) (uri (git-reference (url (str "git://euandre.org/" name)) (commit version))) (sha256 (base32 checksum)) (file-name (git-file-name name version)))) (build-system gnu-build-system) (arguments (list #:strip-binaries? #f #:make-flags #~(list "-e" (string-append "CC=" #$(cc-for-target)) (string-append "PREFIX=" #$output) (string-append "VERSION=" #$version)) #:phases #~(modify-phases %standard-phases (delete 'configure)))) (synopsis #f) ;; FIXME: get (description #f) ;; from tarball! (home-page (str "https://euandre.org/s/" name "/")) (license licenses:agpl3+))) (define-public eut (pkg "eut" "d63e2b55581b5ff65e8b524a65a70650e3e32f71" "1n3bv4pw8yk034ywqp696s8kjw9yqzinvkcig77ylh0cfq7aqhjq")) (define-public remembering (pkg "remembering" "e1570edd3cdaa040f9664adb315f72e33f8b67c2" "0y20flrbjh5gbbzl7h3rimg8jwy2ikgkj03yxclj8qg8mq2f9f4a")) (define-public cage (pkg "cage" "c0482531fc16a55715b759b695d27d555d927ab8" "1v5m7xqfb14y283mlc2kd714hnih1dwcmjcf4i6j52pphjscilys")) (define-public nicely (pkg "nicely" "6699e732f00d2a8d8c377527dc588824ba3cbece" "10n4i35bmzb5lrnch47cfraf32v75bbxm1i2ryjp7b9rsfzw5ds4")) (define-public syskeep (pkg "syskeep" "56b4bd08e9c657e2b1d25daa1e8a66b8cf8887a1" "17d59xhlwidky6jr0mll7rrzq5w4pvk1rf8y3295qf2b3qb1l01c")) (define-public backupit (pkg "backupit" "3e9c89562d566e72cbaa53db3b1d0dfa8050b1f9" "0ayfp9564jggf02zniqay1sb0q0ff94zwxp6p7ps1g2ir2bxm4nm")) (define-public cicd (pkg "cicd" "86cf0c396640a420c078d9bc8637b86a107c3853" "01nhlym2sd14pbqf5lp51r6ljfls5cn1ly23dyfyyln6llcn0s2v")) (define-public guile-heredoc (package (inherit (pkg "guile-heredoc" "065435cdce609604e33b879b9be3e81ab89f3e7b" "179qq17mgi4kakhj9w1dk26afljh5yad4j9ih9d8wms70x6h211m")) (native-inputs (list guile-3.0 texinfo)))) (define-public mkwb (package (inherit (pkg "mkwb" "d6ff6870ef6f7d2d47c102d8722a1e97a911a847" "0q932nr5kzc9pp1rq9l1bxqfwzqnc3cw2g7d711jzdxsjas23p1j")) (propagated-inputs (append (format-inputs (list eut)) (normalize-inputs '(ruby-asciidoctor)))))) (define-public euandre.org (package (inherit (pkg "euandre.org" "960e4410f76801356ebd42801c914b2910a302a7" "1xh69wsy9nz6sz0740fkxg25rhqlw7266k6bzjvfpv19fzav2gcj")) (native-inputs (format-inputs (list mkwb))))) (define-public (format-inputs l) (map (lambda (p) (list (package-name p) p "out")) l)) (define-public (normalize-inputs l) (map (compose (lambda (l) (cons (package-name (car l)) l)) list specification->package+output symbol->string) l)) (define-public (gopkg name inputs version checksum) (let ((p (pkg name version checksum))) (package (inherit p) (arguments (substitute-keyword-arguments (package-arguments p) ((#:phases phases) #~(modify-phases #$phases (add-before 'build 'setenv-golang (lambda _ (define (path->flags option) (let ((search-path (getenv "GOLIBPACKPATH"))) (string-join (map (lambda (path) (string-append option " " path)) (if search-path (string-split search-path #\:) '())) " "))) (setenv "GOCFLAGS" (path->flags "-I")) (setenv "GOLDFLAGS" (path->flags "-L")))))))) (native-inputs (append (format-inputs (list q:go-full)) inputs)) (native-search-paths (list (search-path-specification (variable "GOLIBPACKPATH") (files (list "lib/go")))))))) (define-public guuid (gopkg "guuid" '() "af8ace63d47a9df900b2391cd56be1d8e885c7d0" "1flpnj9n3cwn0770ij8a96jnp0i7vxw3bmjq16nmgr6j39xsk5ac")) (define-public gobang (gopkg "gobang" (format-inputs (list guuid)) "85ac8beaa6b3cd1737b878160e99223c54813a00" "0n0p2psq1524sigvn8nn3g40fhr9afqm6rwsdnnbwx8my0w86yda")) (define-public scrypt (gopkg "scrypt" (format-inputs (list guuid gobang q:scryptkdf eut)) "7847f55afd5d705912d76c266aecd2918ace6eec" "0sdnvlcvfc4xhavjk910xdgvqgxspkvlmnxicd9sn8zkqscd29qv")) (define-public golite (gopkg "golite" (format-inputs (list guuid gobang q:sqlitex)) "aff80f58ac79b07964d999744fe9ec6cb45ed69b" "1x1bc3vryq65wg7xqwmz4m9can1l1p9ibxpv6i7bjjg7k1vbndkg")) (define-public fiinha (gopkg "fiinha" (append (format-inputs (list guuid gobang q:sqlitex golite)) (normalize-inputs '())) "57af51dc3a2a7891249428f5b226ca4593a86d8b" "1yzvc9six5967lb6nv5mlyb6kbjr7kmwx5zhz34gvyszlywh0pf0")) (define-public cracha (gopkg "cracha" (format-inputs (list guuid gobang q:sqlitex golite q:scryptkdf scrypt fiinha)) "e7b379ed40f3695d091c0c5fba1803ac7ea5b1d5" "022bgz54143vai75kxf0gm696mwk8bin773bp427nz74pan7w8p3")) (define-public binder (gopkg "binder" (append (format-inputs (list guuid gobang eut)) (normalize-inputs '(socat lsof))) "2a42c461e0baac3a7330f631606e1281ea0f4068" "1drb4v3n5j160qdsbr4pqgrn3yrqnc69209nrfsiscl835wqkbc2")) (define-public glaze (gopkg "glaze" (append (format-inputs (list guuid gobang)) (normalize-inputs '())) "ad8c95cc5df4b5c10cd23dacf60b9c57b59c7e52" "05qa4pyj3dqxg0gdx0jg4rhh64pi63x0liw26k7d3bm8f8a9b1rc")) (define-public hsts (gopkg "hsts" (append (format-inputs (list guuid gobang)) (normalize-inputs '())) "a1a3cb15b9c7e8767d6baea90fcf1e7dbc1f5a7d" "0pw8ghsk4ifrf9mrmw43b61c06q25i9irnl219rchlg3qvj87avl")) (define-public untls (gopkg "untls" (append (format-inputs (list guuid gobang eut)) (normalize-inputs '())) "4254e3674a33467b4491fbb9bfc896c8382084d7" "0q4f76yz0iza46vnb0zya1fcnn50v6mpg2jjni5gqhibbzjgq8v4")) (define-public wscat (gopkg "wscat" (append (format-inputs (list guuid gobang eut)) (normalize-inputs '())) "6cbb1cdd02f535d53eb1acbd645a39781be29430" "0g46p40hl959b9n70672snip5rci3gpm61p50ihv7hyj0idlv9g1")) (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") (slurp 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 (str "/etc/" name))) (list name (computed-file (str "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) (let ((tuples (map (lambda (path) (list path package)) paths))) (map tuple->entry tuples))) (define-public (package-set symbols records) (append %base-packages records (map (compose list specification->package+output symbol->string) symbols))) (define-public skeletons (etc-entries syskeep '(".profile"))) (define-public base-services %base-services #; (modify-services %base-services (log-rotation-service-type config => (log-rotation-configuration (inherit config) (rc-file (file-append q:rottlog-mailutils-sendmail "/etc/rc")))))) (define-public (activation-gexp name user 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-record-type* syskeep-configuration make-syskeep-configuration syskeep-configuration? (package syskeep-configuration-package (default syskeep)) (tld syskeep-configuration-tld (default #f)) (secrets-user syskeep-configuration-secrets-user (default "secrets-keeper")) (secrets-group syskeep-configuration-secrets-group (default "secrets-keeper")) (become-secrets-group syskeep-configuration-become-secrets-group (default "become-secrets-keeper")) (log-file syskeep-configuration-log-file (default "/var/log/cronjobs/cronjobs.log"))) (define (syskeep-profile config) (match-record config (package) (package-set '(parted glibc-locales guile-heredoc acl bind:utils knot:tools certbot jq file git lsof moreutils mailutils-sendmail curl make borg rsync sqlite strace rlwrap trash-cli tree) (list backupit eut nicely package ;; q cicd)))) (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 env BORG_REPO=/mnt/backup/borg backupit -q cron") #~(job "0 1 * * *" "cronjob backupit -q cron") #~(job "0 2 * * *" "cronjob reconfigure") #~(job "0 3 * * 0" "cronjob gc") #~(job "0 4 * * *" "cronjob guix pull -v3") #~(job "0 5 * * *" "cronjob check")))) (define (syskeep-etc-files config) (match-record config (package) (etc-entries package '("rc.sh" "backupit.txt" "ssh.conf" "init.scm" "gitconfig")))) (define (syskeep-accounts config) (match-record config (secrets-user secrets-group become-secrets-group) (list (user-account (name secrets-user) (group secrets-group) (system? #t) (comment "System account used to manage production secrets") (home-directory "/var/empty") (create-home-directory? #f) (shell (file-append shadow "/sbin/nologin"))) (user-group (name secrets-group) (system? #t)) (user-group (name become-secrets-group) (system? #t))))) (define (syskeep-activation config) (match-record config (tld log-file) (let ((privkey-path (fmt "../../opt/secrets/root@~a.id_rsa.txt" tld))) #~(begin #$(activation-gexp "syskeep" "root" log-file #f #f) (define (dir target) (format (current-error-port) "Creating directory: \"~a\".~%" target) (mkdir-p target)) (define (link from to) (format (current-error-port) "Symlink: \"~a\" -> \"~a\".~%" to from) (when (file-exists? to) (delete-file to)) (symlink from to)) (dir "/var/crash") (chmod "/var/crash" #o777) (link "mnt/production/opt" "/opt") (link "mnt/production/srv" "/srv") (link "../mnt/production/mail" "/var/mail") (dir "/root/.ssh") (link #$privkey-path "/root/.ssh/id_rsa") (link "../../etc/ssh.conf" "/root/.ssh/config") (link "../../etc/id_rsa.pub" "/root/.ssh/id_rsa.pub") (link "../../etc/known_hosts" "/root/.ssh/known_hosts"))))) (define-public (syskeep-sysctl _config) '(("kernel/core_pattern" . "/var/crash/core-%t-%e-%p-%s-%u-%g"))) (define-public syskeep-sudoers-file (plain-file "sudoers-syskeep" "\ root ALL=(ALL) ALL %wheel ALL= ALL %wheel ALL= NOPASSWD: /run/current-system/profile/bin/reconfigure, /run/current-system/profile/bin/herd %become-secrets-keeper ALL=(secrets-keeper) NOPASSWD: /run/current-system/profile/bin/rsync, /run/current-system/profile/bin/setfacl, /run/current-system/profile/bin/rm ")) (define-public syskeep-service-type (service-type (name 'syskeep) (extensions (list (service-extension log-rotation-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 activation-service-type syskeep-activation) (service-extension sysctl-service-type syskeep-sysctl) (service-extension profile-service-type syskeep-profile))) (default-value (syskeep-configuration)) (description "Common configuration of maintained servers."))) (define-record-type* git-configuration make-git-configuration git-configuration? (package git-configuration-package (default git)) (user git-configuration-user (default "git")) (group git-configuration-group (default "git")) (export-all? git-configuration-export-all? (default #f)) (base-path git-configuration-base-path (default "/srv/git")) (user-path git-configuration-user-path (default #f)) (run-in-container? git-configuration-run-in-container? (default #f)) (container-name git-configuration-container-name (default "git-container")) (run-server? git-configuration-run-server? (default #f))) (define-public (git-command config) (match-record config (package user group base-path run-in-container? container-name) (let ((bin (file-append package "/bin/git"))) (if (not run-in-container?) bin (least-authority-wrapper bin #:user user #:group group #:name container-name #:directory base-path #:preserved-environment-variables '() #:mappings (list (file-system-mapping (source base-path) (target source) (writable? #t)))))))) (define-public (git-shepherd-services config) (match-record config (user group export-all? base-path user-path run-server?) (if (not run-server?) (list) (list (shepherd-service (provision '(git)) (requirement '(networking)) (start #~(make-forkexec-constructor (list #$(git-command config) "daemon" "--syslog" "--reuseaddr" #$@(mklist (and export-all? "--export-all")) #$@(mklist (and base-path (str "--base-path=" base-path))) #$@(mklist (and user-path (str "--user-path=" user-path)))) #:user #$user #:group #$group)) (documentation "Daemon process of the git:// protocol.")))))) (define-public (git-accounts config) (match-record config (user group base-path) (list (user-account (name user) (group group) (system? #t) (comment "External SSH Git service user") (home-directory base-path) (create-home-directory? #f)) (user-group (name group) (system? #t))))) (define-public git-service-type (service-type (name 'git) (extensions (list (service-extension shepherd-root-service-type git-shepherd-services) (service-extension account-service-type git-accounts) (service-extension profile-service-type (compose list git-configuration-package)))) (default-value (git-configuration)) (description "Better git:// service."))) (define-record-type* binder-configuration make-binder-configuration binder-configuration? (name binder-configuration-name (default "binder")) (package binder-configuration-package (default 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 '())) (options binder-configuration-options (default '())) (listen-socket binder-configuration-listen-socket (default "0.0.0.0:4443")) (upstream-socket binder-configuration-upstream-socket (default "/var/run/untls/untls.socket"))) (define-record-type* glaze-configuration make-glaze-configuration glaze-configuration? (name glaze-configuration-name (default "glaze")) (package glaze-configuration-package (default 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 "/var/lib/glaze")) (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 '())) (options glaze-configuration-options (default '())) (listen-socket glaze-configuration-listen-socket (default "/var/run/glaze/glaze.socket")) (upstream-socket glaze-configuration-upstream-socket (default #f))) (define-record-type* hsts-configuration make-hsts-configuration hsts-configuration? (name hsts-configuration-name (default "hsts")) (package hsts-configuration-package (default hsts)) (user hsts-configuration-user (default "hsts")) (group hsts-configuration-group (default "hsts")) (log-file hsts-configuration-log-file (default "/var/log/hsts/hsts.log")) (data-directory hsts-configuration-data-directory (default #f)) (run-directory hsts-configuration-run-directory (default "/var/run/hsts")) (run-in-container? hsts-configuration-run-in-container? (default #t)) (container-name hsts-configuration-container-name (default "hsts-container")) (extra-mappings hsts-configuration-extra-mappings (default '())) (options hsts-configuration-options (default '())) (listen-socket hsts-configuration-listen-socket (default "/var/run/hsts/hsts.socket")) (upstream-socket hsts-configuration-upstream-socket (default #f))) (define-record-type* untls-configuration make-untls-configuration untls-configuration? (name untls-configuration-name (default "untls")) (package untls-configuration-package (default 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 '())) (options untls-configuration-options (default '())) (listen-socket untls-configuration-listen-socket (default "/var/run/untls/untls.socket")) (upstream-socket untls-configuration-upstream-socket (default #f))) (define-record-type* wscat-configuration make-wscat-configuration wscat-configuration? (name wscat-configuration-name (default "wscat")) (package wscat-configuration-package (default 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 '())) (options wscat-configuration-options (default '())) (listen-socket wscat-configuration-listen-socket (default "/var/run/wscat/wscat.socket")) (upstream-socket wscat-configuration-upstream-socket (default "/var/run/papod/papod.socket"))) (define-public (profile-for config-type) (lambda (config) (m:match config (($ config-type _name package) (list package))))) (define-public (rotations-for config-type) (lambda (config) (m:match config (($ config-type _name _package _user _group log-file) (list #; (log-rotation (frequency 'weekly) (files (list log-file)) (options '("rotate 5200")))))))) (define-public (activation-for config-type) (lambda (config) (m:match config (($ config-type name _package user _group log-file data-directory run-directory) (activation-gexp name user log-file data-directory run-directory))))) (define-public (accounts-for config-type) (lambda (config) (m:match config (($ 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") (create-home-directory? #f) (shell (file-append shadow "/sbin/nologin")))))))) (define-public (cmd-for config-type config) (m:match config (($ config-type name package user group _log-file data-directory _run-directory run-in-container? container-name extra-mappings) (let ((bin (file-append package (str "/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 (mklist (and data-directory (file-system-mapping (source data-directory) (target source) (writable? #t)))) extra-mappings))))))) (define-public (shepherd-services-for config-type) (lambda (config) (m:match config (($ config-type name _package user group log-file data-directory _run-directory _run-in-container? _container-name _extra-mappings options listen-socket upstream-socket) (list (shepherd-service (provision (list (string->symbol name))) (requirement '(networking)) (auto-start? #f) (start #~(make-forkexec-constructor (list #$(cmd-for config-type config) #$@options #$@(mklist listen-socket) #$@(mklist upstream-socket)) #:user #$user #:group #$group #:log-file #$log-file #:directory #$data-directory)) (documentation (fmt "The Shepherd service that runs the server via \"~a\"." name)))))))) (define-public (service-type-for name config-type config extensions) (service-type (name name) (extensions (append (list (service-extension shepherd-root-service-type (shepherd-services-for config-type)) (service-extension profile-service-type (profile-for config-type)) (service-extension activation-service-type (activation-for config-type)) (service-extension account-service-type (accounts-for config-type)) (service-extension log-rotation-service-type (rotations-for config-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 (without-shepherd-services lst) (filter (lambda (extension) (not (eq? shepherd-root-service-type (service-extension-target extension)))) lst)) (define-public (replacing-shepherd-services service fn) (service-type (inherit service) (extensions (append (without-shepherd-services (service-type-extensions service)) (list (service-extension shepherd-root-service-type fn)))))) (define-public (with-services-from-args service config-type args) (replacing-shepherd-services service (lambda (config) (m:match config (($ config-type _name _package user group log-file data-directory) (map (lambda (tuple) (let ((provision (s1:first tuple)) (args (s1:second tuple))) (shepherd-service (provision provision) (requirement '(networking)) (auto-start? #f) (start #~(make-forkexec-constructor (list #$(cmd-for config-type config) #$@args) #:user #$user #:group #$group #:log-file #$log-file #:directory #$data-directory))))) args)))))) (define-public binder-service-type (service-type-for 'binder (binder-configuration) '())) (define-public glaze-service-type (service-type-for 'glaze (glaze-configuration) '())) (define-public hsts-service-type (service-type-for 'hsts (hsts-configuration) '())) (define-public untls-service-type (service-type-for 'untls (untls-configuration) '())) (define-public wscat-service-type (service-type-for 'wscat (wscat-configuration) '())) (list remembering eut cage backupit nicely syskeep cicd guile-heredoc mkwb euandre.org guuid gobang golite binder glaze hsts untls wscat fiinha cracha)