mirror of
https://codeberg.org/hako/Rosenthal.git
synced 2026-02-20 19:14:20 +00:00
eab1e4b7b9
* modules/rosenthal/utils/services.scm (modify-services/by-name): New macro. * .dir-locals.el (scheme-mode): Add it.
114 lines
3.8 KiB
Scheme
114 lines
3.8 KiB
Scheme
;;; SPDX-License-Identifier: GPL-3.0-or-later
|
||
;;; Copyright © 2026 Hilton Chain <hako@ultrarare.space>
|
||
|
||
(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 ...)))))
|