syndicate-rkt/syndicate/service.rkt

89 lines
3.2 KiB
Racket

#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021-2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(provide (all-from-out syndicate/schemas/service)
with-services
provide-service
standard-actor-system
standard-actor-system/no-services)
(require racket/stxparam)
(require (for-syntax racket/base))
(require syndicate/syntax)
(require syndicate/pattern)
(require syndicate/dataspace)
(require syndicate/schemas/service)
(define-logger syndicate/service)
(define-syntax-parameter registry-dataspace
(lambda (stx)
(raise-syntax-error 'registry-dataspace "Illegal use" stx)))
(define-syntax with-services
(syntax-rules ()
[(_ [service-name ...] body ...)
(at registry-dataspace
(begin (log-syndicate/service-debug "Asserting ~v" (RequireService 'service-name))
(assert (RequireService 'service-name))) ...
(await-services [service-name ...] body ...))]))
(define-syntax await-services
(syntax-rules ()
[(_ [] body ...)
(begin (log-syndicate/service-debug "Ready!")
body ...)]
[(_ [service-name more-services ...] body ...)
(begin (log-syndicate/service-debug "Awaiting ~v" (ServiceState 'service-name (State-ready)))
(during (ServiceState 'service-name (State-ready))
(await-services [more-services ...] body ...)))]))
(define-syntax provide-service
(syntax-rules ()
[(_ [dataspace] body ...)
(module+ #%service
(provide #%service)
(module+ declare-preserve-for-embedding)
(define (#%service service-name dataspace)
(syntax-parameterize ([registry-dataspace (make-rename-transformer #'dataspace)])
(log-syndicate/service-debug "Providing ~v" (ServiceState service-name (State-ready)))
(at dataspace (assert (ServiceState service-name (State-ready))))
body ...)))]))
(define-syntax standard-actor-system/no-services
(syntax-rules ()
[(_ [dataspace] body ...)
(actor-system/dataspace (dataspace)
#:name 'standard-actor-system
(syntax-parameterize ([registry-dataspace (make-rename-transformer #'dataspace)])
(spawn-service-manager dataspace)
body ...))]))
(define-syntax standard-actor-system
(syntax-rules ()
[(_ [dataspace] body ...)
(standard-actor-system/no-services [dataspace]
(with-services [syndicate/drivers/stream
syndicate/drivers/tcp
syndicate/drivers/timer]
body ...))]))
(define (spawn-service-manager ds)
(spawn #:name 'syndicate/service
#:daemon? #t
(at ds
(during/spawn (RequireService $service-name)
#:name service-name
#:daemon? #t
(log-syndicate/service-debug "Starting service ~a" service-name)
(define boot
(dynamic-require `(submod ,service-name #%service)
'#%service
(lambda () (error service-name "No service provided"))))
(boot service-name ds)
(on-stop (log-syndicate/service-debug "Stopping service ~a" service-name))))))