Services and service activation
This commit is contained in:
parent
373fb77fc3
commit
0ab3526cba
|
@ -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
|
||||||
|
|
|
@ -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))))
|
||||||
|
|
|
@ -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)))))))
|
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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)))))))))))
|
|
||||||
|
|
|
@ -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))))))))
|
|
||||||
|
|
|
@ -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))))))))
|
|
||||||
|
|
|
@ -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!"))))))
|
|
||||||
|
|
|
@ -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 ...)]))
|
||||||
|
|
|
@ -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)))))])))))))
|
|
||||||
|
|
|
@ -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)))))))))))
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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)
|
(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))))
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in New Issue