Services and service activation

This commit is contained in:
Tony Garnock-Jones 2021-06-17 14:57:06 +02:00
parent 373fb77fc3
commit 0ab3526cba
19 changed files with 312 additions and 240 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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 Normal file
View File

@ -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:

View File

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

View File

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