diff --git a/.dir-locals.el b/.dir-locals.el index 8e780ec..d7db832 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -42,6 +42,7 @@ . ((eval . (put 'computed-substitution-with-inputs 'scheme-indent-function 1)) (eval . (put 'hidden-desktop-entry 'scheme-indent-function 1)) + (eval . (put 'modify-services/by-name 'scheme-indent-function 1)) (eval . (put 'btrbk-configuration 'scheme-indent-function 0)) (eval . (put 'caddy-configuration 'scheme-indent-function 0)) diff --git a/modules/rosenthal/utils/services.scm b/modules/rosenthal/utils/services.scm new file mode 100644 index 0000000..ad55eec --- /dev/null +++ b/modules/rosenthal/utils/services.scm @@ -0,0 +1,113 @@ +;;; SPDX-License-Identifier: GPL-3.0-or-later +;;; Copyright © 2026 Hilton Chain + +(define-module (rosenthal utils services) + ;; Guile builtins + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-35) + ;; Utilities + #:use-module (guix diagnostics) + #:use-module (guix i18n) + ;; Guix System - services + #:use-module (gnu services) + #:export (modify-services/by-name)) + + +;;; +;;; modify-services/by-name +;;; + +;; Adapted from (gnu services). + +(define-syntax clause-alist + (syntax-rules (=> delete) + ((_ (delete name) rest ...) + (cons (list name + (lambda (service) + #f) + (current-source-location)) + (clause-alist rest ...))) + ((_ (name param => exp ...) rest ...) + (cons (list name + (lambda (svc) + (let ((param (service-value svc))) + (service (service-kind svc) + (begin exp ...)))) + (current-source-location)) + (clause-alist rest ...))) + ((_) + '()))) + +(define (apply-clauses clauses service deleted-services) + (define (raise-if-deleted name properties) + (match (find (match-lambda + ((deleted-name _) + (eq? name deleted-name))) + deleted-services) + ((_ deleted-properties) + (raise (make-compound-condition + (condition + (&error-location + (location (source-properties->location properties)))) + (formatted-message + (G_ "modify-services: service '~a' was deleted here: ~a") + name + (source-properties->location deleted-properties))))) + (_ #t))) + + (match clauses + (((name proc properties) . rest) + (raise-if-deleted name properties) + (if (eq? (and service (service-type-name (service-kind service))) name) + (let ((new-service (proc service))) + (apply-clauses rest new-service + (if new-service + deleted-services + (cons (list name properties) + deleted-services)))) + (apply-clauses rest service deleted-services))) + (() + service))) + +(define (%modify-services services clauses) + (define (raise-if-not-found clause) + (match clause + ((name _ properties) + (unless (find (lambda (service) + (eq? name (service-type-name (service-kind service)))) + services) + (raise (make-compound-condition + (condition + (&error-location + (location (source-properties->location properties)))) + (formatted-message + (G_ "modify-services/by-name: service '~a' not found in service list") + name))))))) + + (for-each raise-if-not-found clauses) + (reverse (filter-map identity + (fold (lambda (service services) + (cons (apply-clauses clauses service '()) + services)) + '() + services)))) + +(define-syntax modify-services/by-name + (syntax-rules () + "Similiar to modify-services but uses the name of the service type instead. +For example: + + (modify-services %base-services + ('guix + config => (guix-configuration + (inherit config) + (use-substitutes? #f) + (extra-options '(\"--gc-keep-derivations\")))) + ('mingetty + config => (mingetty-configuration + (inherit config) + (motd (plain-file \"motd\" \"Hi there!\")))) + (delete 'udev))" + ((_ services clauses ...) + (%modify-services services (clause-alist clauses ...)))))