Crude pseudo-dataspace, plus box-and-client
This commit is contained in:
parent
4eb43a158e
commit
3528391f12
|
@ -1,15 +1,83 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match)
|
||||
(require preserves)
|
||||
|
||||
(require "main.rkt")
|
||||
(require "bag.rkt")
|
||||
(require "schemas/gen/box-protocol.rkt")
|
||||
(require "schemas/gen/dataspace.rkt")
|
||||
|
||||
(define ((box ds) turn)
|
||||
(define value-handle #f)
|
||||
(define (set-value turn value)
|
||||
(set! value-handle (turn-replace! turn ds value-handle (BoxState->preserves (BoxState value)))))
|
||||
(set-value turn 0)
|
||||
(turn-assert! turn ds
|
||||
(Observe->preserves
|
||||
(Observe 'SetBox
|
||||
(turn-ref turn
|
||||
(entity #:message
|
||||
(lambda (turn new-value)
|
||||
(log-info "Box got ~a" new-value)
|
||||
(set-value turn (SetBox-value new-value)))))))))
|
||||
|
||||
(define ((client ds) turn)
|
||||
(turn-assert! turn ds
|
||||
(Observe->preserves
|
||||
(Observe 'BoxState
|
||||
(turn-ref turn
|
||||
(entity #:assert
|
||||
(lambda (turn current-value _handle)
|
||||
(log-info "Client got ~a" current-value)
|
||||
(turn-message! turn ds
|
||||
(SetBox->preserves
|
||||
(SetBox
|
||||
(+ (BoxState-value current-value)
|
||||
1)))))))))))
|
||||
|
||||
(define (dataspace)
|
||||
(define handles (make-hash))
|
||||
(define assertions (make-bag))
|
||||
(define subscriptions (make-hash))
|
||||
(entity #:assert (lambda (turn rec handle)
|
||||
(when (record? rec)
|
||||
(hash-set! handles handle rec)
|
||||
(when (eq? (bag-change! assertions rec +1) 'absent->present)
|
||||
(match (parse-Observe rec)
|
||||
[(? eof-object?) (void)]
|
||||
[(Observe label observer)
|
||||
(define seen (make-hash))
|
||||
(hash-set! (hash-ref! subscriptions label make-hasheq) observer seen)
|
||||
(for [(existing (in-bag assertions))]
|
||||
(when (preserve=? (record-label existing) label)
|
||||
(hash-set! seen existing (turn-assert! turn observer existing))))])
|
||||
(for [((observer seen) (in-hash (hash-ref subscriptions (record-label rec) '#hash())))]
|
||||
(unless (hash-has-key? seen rec)
|
||||
(hash-set! seen rec (turn-assert! turn observer rec)))))))
|
||||
#:retract (lambda (turn upstream-handle)
|
||||
(define rec (hash-ref handles upstream-handle #f))
|
||||
(when rec
|
||||
(hash-remove! handles upstream-handle)
|
||||
(when (eq? (bag-change! assertions rec -1) 'present->absent)
|
||||
(for [(seen (in-hash-values (hash-ref subscriptions (record-label rec) '#hash())))]
|
||||
(turn-retract! turn (hash-ref seen rec))
|
||||
(hash-remove! seen rec))
|
||||
(match (parse-Observe rec)
|
||||
[(? eof-object?) (void)]
|
||||
[(Observe label observer)
|
||||
(let ((subscribers (hash-ref subscriptions label)))
|
||||
(hash-remove! subscribers observer)
|
||||
(when (hash-empty? subscribers)
|
||||
(hash-remove! subscriptions label)))]))))
|
||||
#:message (lambda (turn message)
|
||||
(when (record? message)
|
||||
(for [(peer (in-hash-keys (hash-ref subscriptions (record-label message) '#hash())))]
|
||||
(turn-message! turn peer message))))))
|
||||
|
||||
(actor-system
|
||||
(lambda (turn)
|
||||
(define disarm (facet-prevent-inert-check! (turn-active-facet turn)))
|
||||
(define r1 (turn-ref turn (entity #:message (lambda (turn m)
|
||||
(log-info "r1 got ~v" m)
|
||||
(turn-stop! turn)))))
|
||||
(define r2 (turn-ref turn (entity #:message (lambda (turn m) (log-info "r2 got ~v" m)))))
|
||||
(turn-spawn! turn (lambda (turn)
|
||||
(log-info "Hi!")
|
||||
(turn-message! turn r1 'hello-there-r1)
|
||||
(turn-message! turn r2 'hello-there-r2)))))
|
||||
(define ds (turn-ref turn (dataspace)))
|
||||
(turn-spawn! turn (box ds))
|
||||
(turn-spawn! turn (client ds))))
|
||||
|
|
Loading…
Reference in New Issue