65 lines
2.7 KiB
Racket
65 lines
2.7 KiB
Racket
#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 "schemas/gen/dataspace.rkt")
|
|
(all-from-out "schemas/gen/dataspace-patterns.rkt")
|
|
(all-from-out "schemas/gen/dataspace-patterns.meta.rkt")
|
|
|
|
dataspace
|
|
actor-system/dataspace)
|
|
|
|
(require racket/match)
|
|
|
|
(require preserves)
|
|
|
|
(require "bag.rkt")
|
|
(require "main.rkt")
|
|
(require "skeleton.rkt")
|
|
|
|
(require "schemas/gen/dataspace.rkt")
|
|
(require "schemas/gen/dataspace-patterns.rkt")
|
|
(require "schemas/gen/dataspace-patterns.meta.rkt")
|
|
|
|
(define-logger syndicate/dataspace)
|
|
|
|
(define (dataspace #:name [name (gensym 'dataspace)])
|
|
(define handles (make-hash))
|
|
(define assertions (make-bag))
|
|
(define skeleton (make-empty-skeleton))
|
|
(define ds-e
|
|
(entity #:name name
|
|
#:assert (action (value handle)
|
|
(log-syndicate/dataspace-debug "~v + ~v ~v" ds-e handle value)
|
|
(define maybe-observe (parse-Observe value))
|
|
(hash-set! handles handle (cons value maybe-observe))
|
|
(when (eq? (bag-change! assertions value +1) 'absent->present)
|
|
(match maybe-observe
|
|
[(? eof-object?) (void)]
|
|
[(Observe pat ref) (add-interest! this-turn skeleton pat ref)])
|
|
(add-assertion! this-turn skeleton value)))
|
|
#:retract (action (upstream-handle)
|
|
(match (hash-ref handles upstream-handle #f)
|
|
[#f (error 'dataspace "Peer retracted unknown handle ~v" upstream-handle)]
|
|
[(cons value maybe-observe)
|
|
(log-syndicate/dataspace-debug "~v - ~v ~v" ds-e upstream-handle value)
|
|
(hash-remove! handles upstream-handle)
|
|
(when (eq? (bag-change! assertions value -1) 'present->absent)
|
|
(remove-assertion! this-turn skeleton value)
|
|
(match maybe-observe
|
|
[(? eof-object?) (void)]
|
|
[(Observe pat ref) (remove-interest! this-turn skeleton pat ref)]))]))
|
|
#:message (action (message)
|
|
(log-syndicate/dataspace-debug "~v ! ~v" ds-e message)
|
|
(send-assertion! this-turn skeleton message))))
|
|
ds-e)
|
|
|
|
(define-syntax actor-system/dataspace
|
|
(syntax-rules ()
|
|
[(_ (ds) expr ...)
|
|
(actor-system
|
|
#:name 'dataspace
|
|
(facet-prevent-inert-check! this-facet)
|
|
(define ds (ref (dataspace)))
|
|
expr ...)]))
|