Crude pseudo-dataspace, plus box-and-client

This commit is contained in:
Tony Garnock-Jones 2021-05-28 09:57:11 +02:00
parent 4eb43a158e
commit 3528391f12
1 changed files with 76 additions and 8 deletions

View File

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