Browse Source

Services and service activation

novy
Tony Garnock-Jones 3 months ago
parent
commit
0ab3526cba
  1. 2
      syndicate-examples/box-and-client.rkt
  2. 2
      syndicate-examples/speed-tests/box-and-client/with-dataspace.rkt
  3. 9
      syndicate-examples/tcp-client-naive.rkt
  4. 6
      syndicate-examples/tcp-client.rkt
  5. 20
      syndicate-examples/tcp-echo-server-explicit.rkt
  6. 14
      syndicate-examples/tcp-echo-server.rkt
  7. 18
      syndicate-examples/tcp-relay-server.rkt
  8. 15
      syndicate-examples/timer-demo.rkt
  9. 23
      syndicate/dataspace.rkt
  10. 48
      syndicate/distributed/tcp-server.rkt
  11. 33
      syndicate/drivers/racket-event.rkt
  12. 4
      syndicate/drivers/stream.rkt
  13. 115
      syndicate/drivers/tcp.rkt
  14. 169
      syndicate/drivers/timer.rkt
  15. 2
      syndicate/main.rkt
  16. 5
      syndicate/schemas/service.prs
  17. 86
      syndicate/service.rkt
  18. 3
      syndicate/test/core/during-with-spawn.rkt
  19. 2
      syndicate/test/core/self-loop.rkt

2
syndicate-examples/box-and-client.rkt

@ -8,7 +8,7 @@
(assertion-struct box-state (value))
(module+ main
(actor-system/dataspace (ds)
(standard-actor-system/no-services (ds)
(spawn #:name 'box
(define-field current-value 0)
(at ds

2
syndicate-examples/speed-tests/box-and-client/with-dataspace.rkt

@ -27,6 +27,6 @@
(module+ main
(time
(actor-system/dataspace (ds)
(standard-actor-system (ds)
(box ds 500000 100000)
(client ds))))

9
syndicate-examples/tcp-client-naive.rkt

@ -19,9 +19,6 @@
[("--port" "-p") port-number "Set port number to connect to"
(set! port (string->number port-number))])
(actor-system/dataspace (ds)
(spawn-racket-event-driver ds)
(spawn-tcp-driver ds)
(spawn
(at ds
(assert (StreamConnection (port-lines-source ds) (port-sink) (TcpRemote host port)))))))
(standard-actor-system (ds)
(at ds
(assert (StreamConnection (port-lines-source ds) (port-sink) (TcpRemote host port))))))

6
syndicate-examples/tcp-client.rkt

@ -17,10 +17,8 @@
[("--port" "-p") port-number "Set port number to connect to"
(set! port (string->number port-number))])
(actor-system/dataspace (ds)
(spawn-racket-event-driver ds)
(spawn-tcp-driver ds)
(spawn
(standard-actor-system (ds)
(with-services [syndicate/drivers/racket-event]
(establish-connection
ds (TcpRemote host port)
#:initial-mode (Mode-lines (LineMode-lf))

20
syndicate-examples/tcp-echo-server-explicit.rkt

@ -15,14 +15,12 @@
[("--port" "-p") port-number "Set port number to listen on"
(set! port (string->number port-number))])
(actor-system/dataspace (ds)
(spawn-tcp-driver ds)
(spawn
(at ds
(assert (StreamListener (TcpLocal host port)
(make-connection-handler
(lambda (source sink)
(handle-connection source sink
#:on-data
(lambda (data mode)
(send-data sink data mode)))))))))))
(standard-actor-system (ds)
(at ds
(assert (StreamListener (TcpLocal host port)
(make-connection-handler
(lambda (source sink)
(handle-connection source sink
#:on-data
(lambda (data mode)
(send-data sink data mode))))))))))

14
syndicate-examples/tcp-echo-server.rkt

@ -15,11 +15,9 @@
[("--port" "-p") port-number "Set port number to listen on"
(set! port (string->number port-number))])
(actor-system/dataspace (ds)
(spawn-tcp-driver ds)
(spawn
(at ds
(stop-on (asserted (TcpListenError (TcpLocal host port) $message)))
(during/spawn (StreamConnection $source $sink (TcpLocal host port))
(handle-connection source sink
#:on-data (lambda (data mode) (send-data sink data mode))))))))
(standard-actor-system (ds)
(at ds
(stop-on (asserted (TcpListenError (TcpLocal host port) $message)))
(during/spawn (StreamConnection $source $sink (TcpLocal host port))
(handle-connection source sink
#:on-data (lambda (data mode) (send-data sink data mode)))))))

18
syndicate-examples/tcp-relay-server.rkt

@ -17,13 +17,11 @@
(message-struct Line (text))
(actor-system/dataspace (ds)
(spawn-tcp-driver ds)
(spawn
(at ds
(stop-on (asserted (TcpListenError (TcpLocal host port) $message)))
(during/spawn (StreamConnection $source $sink (TcpLocal host port))
(handle-connection source sink
#:initial-mode (Mode-lines (LineMode-lf))
#:on-data (lambda (data mode) (send! ds (Line data))))
(at ds (on (message (Line $data)) (send-line sink data))))))))
(standard-actor-system (ds)
(at ds
(stop-on (asserted (TcpListenError (TcpLocal host port) $message)))
(during/spawn (StreamConnection $source $sink (TcpLocal host port))
(handle-connection source sink
#:initial-mode (Mode-lines (LineMode-lf))
#:on-data (lambda (data mode) (send! ds (Line data))))
(at ds (on (message (Line $data)) (send-line sink data)))))))

15
syndicate-examples/timer-demo.rkt

@ -5,11 +5,10 @@
(require syndicate/drivers/timer)
(module+ main
(actor-system/dataspace (ds)
(spawn-timer-driver ds)
(spawn (at ds
(log-info "waiting...")
(on (timeout 1000)
(log-info "still waiting..."))
(stop-on (timeout 2000)
(log-info "done!"))))))
(standard-actor-system (ds)
(at ds
(log-info "waiting...")
(on (timeout 1000)
(log-info "still waiting..."))
(stop-on (timeout 2000)
(log-info "done!")))))

23
syndicate/dataspace.rkt

@ -9,13 +9,18 @@
dataspace
actor-system/dataspace)
(require (for-syntax racket/base))
(require (for-syntax syntax/parse))
(require racket/pretty)
(require racket/match)
(require preserves)
(require "bag.rkt")
(require "main.rkt")
(require "actor.rkt")
(require "syntax.rkt")
(require "syntax-classes.rkt")
(require "skeleton.rkt")
(require "schemas/gen/dataspace.rkt")
@ -67,11 +72,11 @@
(send-assertion! this-turn skeleton message))))
(ref ds-e))
(define-syntax actor-system/dataspace
(syntax-rules ()
[(_ (ds) expr ...)
(actor-system
#:name 'dataspace
(facet-prevent-inert-check! this-facet)
(define ds (dataspace))
expr ...)]))
(define-syntax (actor-system/dataspace stx)
(syntax-parse stx
[(_ (ds) name:<name> expr ...)
#'(actor-system
#:name name.N
(facet-prevent-inert-check! this-facet)
(define ds (dataspace))
expr ...)]))

48
syndicate/distributed/tcp-server.rkt

@ -14,7 +14,7 @@
(require syndicate/drivers/tcp)
(module+ main
(actor-system/dataspace (ds)
(standard-actor-system (ds)
(define ds-oid "syndicate")
(define ds-key (make-bytes KEY_LENGTH))
(at ds (assert (Bind ds-oid ds-key ds)))
@ -24,27 +24,25 @@
(newline)
(displayln (bytes->hex-string (sturdy-encode (->preserve root-cap))))
(spawn-tcp-driver ds)
(spawn #:name 'tcp-server
(define spec (TcpLocal "0.0.0.0" 5999))
(at ds
(stop-on (asserted (TcpListenError spec _)))
(during/spawn (StreamConnection $source $sink spec)
#:name (list 'tcp-server source)
(run-relay #:packet-writer (lambda (bs) (send-data sink bs))
#:setup-inputs
(lambda (tr)
(handle-connection source sink
#:on-data (lambda (d _m) (accept-bytes tr d))))
#:initial-ref
(object #:name 'gatekeeper
[(Resolve unvalidated-sturdyref observer)
(at ds
(during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
(define sturdyref (validate unvalidated-sturdyref key))
(define attenuation
(append-map Attenuation-value
(reverse (SturdyRef-caveatChain sturdyref))))
(define attenuated-target
(apply attenuate-entity-ref target attenuation))
(at observer (assert (embedded attenuated-target)))))])))))))
(define spec (TcpLocal "0.0.0.0" 5999))
(at ds
(stop-on (asserted (TcpListenError spec _)))
(during/spawn (StreamConnection $source $sink spec)
#:name (list 'tcp-server source)
(run-relay #:packet-writer (lambda (bs) (send-data sink bs))
#:setup-inputs
(lambda (tr)
(handle-connection source sink
#:on-data (lambda (d _m) (accept-bytes tr d))))
#:initial-ref
(object #:name 'gatekeeper
[(Resolve unvalidated-sturdyref observer)
(at ds
(during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
(define sturdyref (validate unvalidated-sturdyref key))
(define attenuation
(append-map Attenuation-value
(reverse (SturdyRef-caveatChain sturdyref))))
(define attenuated-target
(apply attenuate-entity-ref target attenuation))
(at observer (assert (embedded attenuated-target)))))]))))))

33
syndicate/drivers/racket-event.rkt

@ -4,8 +4,7 @@
;; Generic Racket events.
(provide (all-from-out syndicate/schemas/gen/racket-event)
spawn-racket-event-driver)
(provide (all-from-out syndicate/schemas/gen/racket-event))
(require syndicate/driver-support)
(require syndicate/schemas/gen/racket-event)
@ -13,20 +12,16 @@
(define-logger syndicate/drivers/racket-event)
(define (spawn-racket-event-driver ds)
(spawn #:name 'racket-event-driver
#:daemon? #t
(at ds
(during/spawn (Observe (:pattern (RacketEvent ,(DLit $embedded-event) ,_)) _)
#:name (embedded-value embedded-event)
(define event (embedded-value embedded-event))
(on-start (log-syndicate/drivers/racket-event-debug "started listening: ~v" event))
(on-stop (log-syndicate/drivers/racket-event-debug "stopped listening: ~v" event))
(linked-thread
#:name (list event 'thread)
(lambda (facet)
(let loop ()
(sync (handle-evt event
(lambda args
(turn! facet (lambda () (send! ds (RacketEvent event args))))
(loop)))))))))))
(provide-service [ds]
(at ds
(during/spawn (Observe (:pattern (RacketEvent ,(DLit $embedded-event) ,_)) _)
#:name (embedded-value embedded-event)
(define event (embedded-value embedded-event))
(linked-thread
#:name (list event 'thread)
(lambda (facet)
(let loop ()
(sync (handle-evt event
(lambda args
(turn! facet (lambda () (send! ds (RacketEvent event args))))
(loop))))))))))

4
syndicate/drivers/stream.rkt

@ -8,12 +8,14 @@
(require (only-in racket/port read-line-evt))
(require "tcp.rkt") ;; ugh, lots of tcp.rkt actually belongs in this file
(require "racket-event.rkt")
(require syndicate/drivers/racket-event)
(require syndicate/service)
(define (port-lines-source ds [port (current-input-port)]
#:initial-credit [initial-credit 0]
#:name [name (list 'port-lines-source (object-name port))]
#:line-mode [line-mode (LineMode-lf)])
(at ds (assert (RequireService 'syndicate/drivers/racket-event)))
(define-field credit initial-credit)
(define-field sink #f)
(at ds

115
syndicate/drivers/tcp.rkt

@ -4,7 +4,6 @@
(provide (all-from-out syndicate/schemas/gen/stream)
(all-from-out syndicate/schemas/gen/tcp)
spawn-tcp-driver
handle-connection
make-source
@ -35,27 +34,24 @@
(define-logger syndicate/drivers/tcp)
(define (spawn-tcp-driver ds)
(spawn
#:name 'tcp-driver
#:daemon? #t
(at ds
(during/spawn (Observe (:pattern (StreamConnection ,_ ,_ ,$spec-pat)) _)
#:name (list 'simple-listener spec-pat)
(match (pattern->constant spec-pat)
[(? void?) (stop-current-facet)]
[spec (at ds
(during (StreamSpecListenable spec)
(assert
(StreamListener spec
(make-connection-handler
(lambda (source sink)
(assert (StreamConnection source sink spec))))))))]))
(during/spawn (StreamConnection $app-source $app-sink $spec)
#:name (list 'simple-connection spec)
(at ds
(provide-service [ds]
(at ds
(during/spawn (Observe (:pattern (StreamConnection ,_ ,_ ,$spec-pat)) _)
#:name (list 'simple-listener spec-pat)
(match (pattern->constant spec-pat)
[(? void?) (stop-current-facet)]
[spec (at ds
(during (StreamSpecListenable spec)
(assert
(StreamListener spec
(make-connection-handler
(lambda (source sink)
(assert (StreamConnection source sink spec))))))))]))
(during/spawn (StreamConnection $app-source $app-sink $spec)
#:name (list 'simple-connection spec)
(at ds
(during (StreamSpecConnectable spec)
(assert (StreamConnect spec
(object #:name 'connection-peer
[(ConnectionHandler-connected sys-source sys-sink)
@ -66,43 +62,43 @@
"Connection to ~a rejected: ~a" spec message)
(at app-source (assert (StreamError message)))
(at app-sink (assert (StreamError message)))
(stop-current-facet)])))))
;; I translate interest in StreamListener with a particular spec-pattern into a facet
;; that reacts to interest in StreamSpecListenable with a spec matching the spec-pattern
;; by asserting StreamSpecListenable with that spec.
(during (Observe (:pattern (StreamListener ,$spec-pat ,_)) _)
(define listenable-asserter
(object [bindings
(define spec
(pattern->constant spec-pat (lambda (_name index) (list-ref bindings index))))
(assert (StreamSpecListenable spec))]))
(assert
(Observe (:pattern
(Observe (:pattern (StreamSpecListenable ,,(:pattern (DLit ,spec-pat)))) _))
listenable-asserter)))
;; I translate interest in StreamConnect with a particular spec-pattern into a facet that
;; reacts to interest in StreamSpecConnectable with a spec matching the spec-pattern by
;; asserting StreamSpecConnectable with that spec.
(during (Observe (:pattern (StreamConnect ,$spec-pat ,_)) _)
(define connectable-asserter
(object [bindings
(define spec
(pattern->constant spec-pat (lambda (_name index) (list-ref bindings index))))
(assert (StreamSpecConnectable spec))]))
(assert
(Observe (:pattern
(Observe (:pattern (StreamSpecConnectable ,,(:pattern (DLit ,spec-pat)))) _))
connectable-asserter)))
(during/spawn (StreamListener (TcpLocal $host $port) $peer)
#:name (TcpLocal host port)
(run-listener ds peer host port))
(during/spawn (StreamConnect (TcpRemote $host $port) $peer)
#:name (TcpRemote host port)
(run-outbound ds peer host port)))))
(stop-current-facet)]))))))
;; I translate interest in StreamListener with a particular spec-pattern into a facet
;; that reacts to interest in StreamSpecListenable with a spec matching the spec-pattern
;; by asserting StreamSpecListenable with that spec.
(during (Observe (:pattern (StreamListener ,$spec-pat ,_)) _)
(define listenable-asserter
(object [bindings
(define spec
(pattern->constant spec-pat (lambda (_name index) (list-ref bindings index))))
(assert (StreamSpecListenable spec))]))
(assert
(Observe (:pattern
(Observe (:pattern (StreamSpecListenable ,,(:pattern (DLit ,spec-pat)))) _))
listenable-asserter)))
;; I translate interest in StreamConnect with a particular spec-pattern into a facet that
;; reacts to interest in StreamSpecConnectable with a spec matching the spec-pattern by
;; asserting StreamSpecConnectable with that spec.
(during (Observe (:pattern (StreamConnect ,$spec-pat ,_)) _)
(define connectable-asserter
(object [bindings
(define spec
(pattern->constant spec-pat (lambda (_name index) (list-ref bindings index))))
(assert (StreamSpecConnectable spec))]))
(assert
(Observe (:pattern
(Observe (:pattern (StreamSpecConnectable ,,(:pattern (DLit ,spec-pat)))) _))
connectable-asserter)))
(during/spawn (StreamListener (TcpLocal $host $port) $peer)
#:name (TcpLocal host port)
(run-listener ds peer host port))
(during/spawn (StreamConnect (TcpRemote $host $port) $peer)
#:name (TcpRemote host port)
(run-outbound ds peer host port))))
(define (run-listener ds peer host port)
(on-start (log-syndicate/drivers/tcp-info "+listener on ~v ~v" host port))
@ -134,6 +130,7 @@
(and remote-end (TcpRemote remote-host remote-port))))
(tcp-ends i))
(define name (format "[~a:~a::~a:~a]" local-host local-port remote-host remote-port))
(log-syndicate/drivers/tcp-info "Connection ~a established" name)
(spawn #:name name
(actor-add-exit-hook! this-actor (lambda ()
(close-input-port i)

169
syndicate/drivers/timer.rkt

@ -3,7 +3,6 @@
;;; SPDX-FileCopyrightText: Copyright © 2018-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(provide (all-from-out syndicate/schemas/gen/timer)
spawn-timer-driver
timeout)
(require syndicate/driver-support)
@ -14,94 +13,90 @@
(define-logger syndicate/drivers/timer)
(define (spawn-timer-driver ds)
(spawn
#:name 'timer-driver
#:daemon? #t
(define control-ch (make-channel))
(linked-thread
#:name 'timer-driver-thread
(lambda (facet)
(struct pending-timer (deadline label) #:transparent)
(define engine (actor-engine (facet-actor facet)))
(define heap
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
(define timers (make-hash))
(define (next-timer)
(and (positive? (heap-count heap))
(heap-min heap)))
(define (fire-timers! now)
(define count-fired 0)
(let loop ()
(when (positive? (heap-count heap))
(let ((m (heap-min heap)))
(when (<= (pending-timer-deadline m) now)
(define label (pending-timer-label m))
(heap-remove-min! heap)
(hash-remove! timers label)
(log-syndicate/drivers/timer-debug "expired timer ~a" label)
(turn! facet (lambda () (send! ds (TimerExpired label now))))
(set! count-fired (+ count-fired 1))
(loop)))))
(adjust-inhabitant-count! engine (- count-fired)))
(define (clear-timer! label)
(match (hash-ref timers label #f)
[#f (void)]
[deadline
(heap-remove! heap (pending-timer deadline label))
(hash-remove! timers label)
(adjust-inhabitant-count! engine -1)]))
(define (install-timer! label deadline)
(clear-timer! label)
(heap-add! heap (pending-timer deadline label))
(hash-set! timers label deadline)
(adjust-inhabitant-count! engine 1))
(provide-service [ds]
(define control-ch (make-channel))
(linked-thread
#:name 'timer-driver-thread
(lambda (facet)
(struct pending-timer (deadline label) #:transparent)
(define engine (actor-engine (facet-actor facet)))
(define heap
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
(define timers (make-hash))
(define (next-timer)
(and (positive? (heap-count heap))
(heap-min heap)))
(define (fire-timers! now)
(define count-fired 0)
(let loop ()
(sync (match (next-timer)
[#f never-evt]
[t (handle-evt (alarm-evt (pending-timer-deadline t))
(lambda (_dummy)
(define now (current-inexact-milliseconds))
(fire-timers! now)
(loop)))])
(handle-evt control-ch
(lambda (m)
(match (parse-SetTimer m)
[(SetTimer label _ (TimerKind-clear))
(clear-timer! label)
(loop)]
[(SetTimer label msecs (TimerKind-relative))
(define deadline (+ (current-inexact-milliseconds) msecs))
(install-timer! label deadline)
(loop)]
[(SetTimer label deadline (TimerKind-absolute))
(install-timer! label deadline)
(loop)])))))))
(at ds
(on (message ($ instruction (SetTimer _ _ _)))
(log-syndicate/drivers/timer-debug "received instruction ~a" instruction)
(channel-put control-ch instruction))
(during (Observe (:pattern (LaterThan ,(DLit $msecs))) _)
(log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
msecs
(current-inexact-milliseconds))
(define timer-id (gensym 'timestate))
(on-start (send! (SetTimer timer-id msecs (TimerKind-absolute))))
(on-stop (send! (SetTimer timer-id msecs (TimerKind-clear))))
(on (message (TimerExpired timer-id _))
(react (assert (LaterThan msecs))))))))
(when (positive? (heap-count heap))
(let ((m (heap-min heap)))
(when (<= (pending-timer-deadline m) now)
(define label (pending-timer-label m))
(heap-remove-min! heap)
(hash-remove! timers label)
(log-syndicate/drivers/timer-debug "expired timer ~a" label)
(turn! facet (lambda () (send! ds (TimerExpired label now))))
(set! count-fired (+ count-fired 1))
(loop)))))
(adjust-inhabitant-count! engine (- count-fired)))
(define (clear-timer! label)
(match (hash-ref timers label #f)
[#f (void)]
[deadline
(heap-remove! heap (pending-timer deadline label))
(hash-remove! timers label)
(adjust-inhabitant-count! engine -1)]))
(define (install-timer! label deadline)
(clear-timer! label)
(heap-add! heap (pending-timer deadline label))
(hash-set! timers label deadline)
(adjust-inhabitant-count! engine 1))
(let loop ()
(sync (match (next-timer)
[#f never-evt]
[t (handle-evt (alarm-evt (pending-timer-deadline t))
(lambda (_dummy)
(define now (current-inexact-milliseconds))
(fire-timers! now)
(loop)))])
(handle-evt control-ch
(lambda (m)
(match (parse-SetTimer m)
[(SetTimer label _ (TimerKind-clear))
(clear-timer! label)
(loop)]
[(SetTimer label msecs (TimerKind-relative))
(define deadline (+ (current-inexact-milliseconds) msecs))
(install-timer! label deadline)
(loop)]
[(SetTimer label deadline (TimerKind-absolute))
(install-timer! label deadline)
(loop)])))))))
(at ds
(on (message ($ instruction (SetTimer _ _ _)))
(log-syndicate/drivers/timer-debug "received instruction ~a" instruction)
(channel-put control-ch instruction))
(during (Observe (:pattern (LaterThan ,(DLit $msecs))) _)
(log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a"
msecs
(current-inexact-milliseconds))
(define timer-id (gensym 'timestate))
(on-start (send! (SetTimer timer-id msecs (TimerKind-absolute))))
(on-stop (send! (SetTimer timer-id msecs (TimerKind-clear))))
(on (message (TimerExpired timer-id _))
(react (assert (LaterThan msecs)))))))
(define-event-expander timeout
(syntax-rules ()

2
syndicate/main.rkt

@ -6,6 +6,7 @@
(provide (except-out (all-from-out "actor.rkt") current-turn)
(struct-out entity-ref)
(all-from-out "syntax.rkt")
(all-from-out "service.rkt")
(all-from-out "event-expander.rkt")
(all-from-out preserves)
(all-from-out preserves-schema)
@ -18,6 +19,7 @@
(require "actor.rkt")
(require "entity-ref.rkt")
(require "syntax.rkt")
(require "service.rkt")
(require "event-expander.rkt")
(require preserves)
(require preserves-schema)

5
syndicate/schemas/service.prs

@ -0,0 +1,5 @@
version 1 .
embeddedType EntityRef.Ref .
RequireService = <require-service @service-name any>.
ServiceRunning = <service-running @service-name any>.

86
syndicate/service.rkt

@ -0,0 +1,86 @@
#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(provide (all-from-out syndicate/schemas/gen/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/gen/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 ()
[(_ [] body ...)
(begin body ...)]
[(_ [service-name more-services ...] body ...)
(at registry-dataspace
(during (ServiceRunning 'service-name)
(with-services [more-services ...] body ...)))]))
(define-syntax provide-service
(syntax-rules ()
[(_ [dataspace] body ...)
(module+ #%service
(provide #%service)
(define (#%service service-name dataspace)
(syntax-parameterize ([registry-dataspace (make-rename-transformer #'dataspace)])
(at dataspace (assert (ServiceRunning service-name)))
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/tcp
syndicate/drivers/timer]
body ...))]))
(define (spawn-service-manager ds)
(spawn #:name 'syndicate/service
#:daemon? #t
(at ds
(during (Observe (:pattern (ServiceRunning ,(DLit $service-name))) _)
(assert (RequireService service-name)))
(during/spawn (RequireService $service-name)
#:name service-name
#:daemon? #t
(log-syndicate/service-info "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-info "Stopping service ~a" service-name))))))
;;---------------------------------------------------------------------------
;;; Local Variables:
;;; eval: (put 'provide-service 'racket-indent-function 1)
;;; eval: (put 'standard-actor-system 'racket-indent-function 1)
;;; eval: (put 'standard-actor-system/no-services 'racket-indent-function 1)
;;; End:

3
syndicate/test/core/during-with-spawn.rkt

@ -5,8 +5,7 @@
(require syndicate/drivers/timer)
(module+ test
(actor-system/dataspace (ds)
(spawn-timer-driver ds)
(standard-actor-system (ds)
(spawn (at ds
(assert 'item)
(on (timeout 50) (stop-current-facet))))

2
syndicate/test/core/self-loop.rkt

@ -3,7 +3,7 @@
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(module+ test
(actor-system/dataspace (ds)
(standard-actor-system (ds)
(spawn
(define (loop n)
(log-info "loop ~v" n)

Loading…
Cancel
Save