Services and service activation
This commit is contained in:
parent
373fb77fc3
commit
0ab3526cba
|
@ -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
|
||||
|
|
|
@ -27,6 +27,6 @@
|
|||
|
||||
(module+ main
|
||||
(time
|
||||
(actor-system/dataspace (ds)
|
||||
(standard-actor-system (ds)
|
||||
(box ds 500000 100000)
|
||||
(client ds))))
|
||||
|
|
|
@ -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
|
||||
(standard-actor-system (ds)
|
||||
(at ds
|
||||
(assert (StreamConnection (port-lines-source ds) (port-sink) (TcpRemote host port)))))))
|
||||
(assert (StreamConnection (port-lines-source ds) (port-sink) (TcpRemote host port))))))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -15,9 +15,7 @@
|
|||
[("--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
|
||||
(standard-actor-system (ds)
|
||||
(at ds
|
||||
(assert (StreamListener (TcpLocal host port)
|
||||
(make-connection-handler
|
||||
|
@ -25,4 +23,4 @@
|
|||
(handle-connection source sink
|
||||
#:on-data
|
||||
(lambda (data mode)
|
||||
(send-data sink data mode)))))))))))
|
||||
(send-data sink data mode))))))))))
|
||||
|
|
|
@ -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
|
||||
(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))))))))
|
||||
#:on-data (lambda (data mode) (send-data sink data mode)))))))
|
||||
|
|
|
@ -17,13 +17,11 @@
|
|||
|
||||
(message-struct Line (text))
|
||||
|
||||
(actor-system/dataspace (ds)
|
||||
(spawn-tcp-driver ds)
|
||||
(spawn
|
||||
(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))))))))
|
||||
(at ds (on (message (Line $data)) (send-line sink data)))))))
|
||||
|
|
|
@ -5,11 +5,10 @@
|
|||
(require syndicate/drivers/timer)
|
||||
|
||||
(module+ main
|
||||
(actor-system/dataspace (ds)
|
||||
(spawn-timer-driver ds)
|
||||
(spawn (at ds
|
||||
(standard-actor-system (ds)
|
||||
(at ds
|
||||
(log-info "waiting...")
|
||||
(on (timeout 1000)
|
||||
(log-info "still waiting..."))
|
||||
(stop-on (timeout 2000)
|
||||
(log-info "done!"))))))
|
||||
(log-info "done!")))))
|
||||
|
|
|
@ -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
|
||||
(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 ...)]))
|
||||
|
|
|
@ -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,8 +24,6 @@
|
|||
(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 _)))
|
||||
|
@ -47,4 +45,4 @@
|
|||
(reverse (SturdyRef-caveatChain sturdyref))))
|
||||
(define attenuated-target
|
||||
(apply attenuate-entity-ref target attenuation))
|
||||
(at observer (assert (embedded attenuated-target)))))])))))))
|
||||
(at observer (assert (embedded attenuated-target)))))]))))))
|
||||
|
|
|
@ -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,15 +12,11 @@
|
|||
|
||||
(define-logger syndicate/drivers/racket-event)
|
||||
|
||||
(define (spawn-racket-event-driver ds)
|
||||
(spawn #:name 'racket-event-driver
|
||||
#:daemon? #t
|
||||
(provide-service [ds]
|
||||
(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)
|
||||
|
@ -29,4 +24,4 @@
|
|||
(sync (handle-evt event
|
||||
(lambda args
|
||||
(turn! facet (lambda () (send! ds (RacketEvent event args))))
|
||||
(loop)))))))))))
|
||||
(loop))))))))))
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,11 +34,7 @@
|
|||
|
||||
(define-logger syndicate/drivers/tcp)
|
||||
|
||||
(define (spawn-tcp-driver ds)
|
||||
(spawn
|
||||
#:name 'tcp-driver
|
||||
#:daemon? #t
|
||||
|
||||
(provide-service [ds]
|
||||
(at ds
|
||||
(during/spawn (Observe (:pattern (StreamConnection ,_ ,_ ,$spec-pat)) _)
|
||||
#:name (list 'simple-listener spec-pat)
|
||||
|
@ -56,6 +51,7 @@
|
|||
(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,7 +62,7 @@
|
|||
"Connection to ~a rejected: ~a" spec message)
|
||||
(at app-source (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
|
||||
;; that reacts to interest in StreamSpecListenable with a spec matching the spec-pattern
|
||||
|
@ -102,7 +98,7 @@
|
|||
|
||||
(during/spawn (StreamConnect (TcpRemote $host $port) $peer)
|
||||
#:name (TcpRemote host port)
|
||||
(run-outbound ds peer 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)
|
||||
|
|
|
@ -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,11 +13,7 @@
|
|||
|
||||
(define-logger syndicate/drivers/timer)
|
||||
|
||||
(define (spawn-timer-driver ds)
|
||||
(spawn
|
||||
#:name 'timer-driver
|
||||
#:daemon? #t
|
||||
|
||||
(provide-service [ds]
|
||||
(define control-ch (make-channel))
|
||||
|
||||
(linked-thread
|
||||
|
@ -101,7 +96,7 @@
|
|||
(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))))))))
|
||||
(react (assert (LaterThan msecs)))))))
|
||||
|
||||
(define-event-expander timeout
|
||||
(syntax-rules ()
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -0,0 +1,5 @@
|
|||
version 1 .
|
||||
embeddedType EntityRef.Ref .
|
||||
|
||||
RequireService = <require-service @service-name any>.
|
||||
ServiceRunning = <service-running @service-name any>.
|
|
@ -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:
|
|
@ -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))))
|
||||
|
|
|
@ -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…
Reference in New Issue