2021-06-02 13:00:25 +00:00
|
|
|
#lang racket/base
|
2021-06-04 14:20:14 +00:00
|
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
2022-01-16 08:48:18 +00:00
|
|
|
;;; SPDX-FileCopyrightText: Copyright © 2021-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
2021-06-02 13:00:25 +00:00
|
|
|
|
2021-07-01 07:40:52 +00:00
|
|
|
(provide (all-from-out "schemas/dataspace.rkt")
|
|
|
|
(all-from-out "schemas/dataspacePatterns.rkt")
|
|
|
|
(all-from-out "schemas/dataspacePatterns.meta.rkt")
|
2021-06-02 13:00:25 +00:00
|
|
|
|
2021-06-03 20:40:51 +00:00
|
|
|
dataspace
|
|
|
|
actor-system/dataspace)
|
2021-06-02 13:00:25 +00:00
|
|
|
|
2021-06-17 12:57:06 +00:00
|
|
|
(require (for-syntax racket/base))
|
|
|
|
(require (for-syntax syntax/parse))
|
|
|
|
|
2021-06-17 11:38:30 +00:00
|
|
|
(require racket/pretty)
|
2021-06-02 13:00:25 +00:00
|
|
|
(require racket/match)
|
|
|
|
|
|
|
|
(require preserves)
|
|
|
|
|
|
|
|
(require "bag.rkt")
|
2021-06-17 12:57:06 +00:00
|
|
|
(require "actor.rkt")
|
|
|
|
(require "syntax.rkt")
|
|
|
|
(require "syntax-classes.rkt")
|
2021-06-03 13:59:17 +00:00
|
|
|
(require "skeleton.rkt")
|
2021-06-02 13:00:25 +00:00
|
|
|
|
2021-07-01 07:40:52 +00:00
|
|
|
(require "schemas/dataspace.rkt")
|
|
|
|
(require "schemas/dataspacePatterns.rkt")
|
|
|
|
(require "schemas/dataspacePatterns.meta.rkt")
|
2021-06-02 13:00:25 +00:00
|
|
|
|
2021-06-03 13:59:17 +00:00
|
|
|
(define-logger syndicate/dataspace)
|
|
|
|
|
2021-06-17 11:38:30 +00:00
|
|
|
(match (getenv "SYNDICATE_COLUMNS")
|
|
|
|
[#f (void)]
|
|
|
|
[n (pretty-print-columns (string->number n))])
|
|
|
|
|
|
|
|
(define (pretty-assertion indent value)
|
|
|
|
(define gap (make-string indent #\space))
|
|
|
|
(parameterize ((pretty-print-print-line
|
|
|
|
(lambda (line-number port line-length columns)
|
|
|
|
(fprintf port "\n~a" gap)
|
|
|
|
indent)))
|
|
|
|
(pretty-format value #:mode 'print)))
|
|
|
|
|
2021-06-03 20:38:11 +00:00
|
|
|
(define (dataspace #:name [name (gensym 'dataspace)])
|
2021-06-02 13:00:25 +00:00
|
|
|
(define handles (make-hash))
|
|
|
|
(define assertions (make-bag))
|
2021-06-03 13:59:17 +00:00
|
|
|
(define skeleton (make-empty-skeleton))
|
|
|
|
(define ds-e
|
2021-06-03 20:38:11 +00:00
|
|
|
(entity #:name name
|
2021-06-10 09:42:07 +00:00
|
|
|
#:assert (lambda (value handle)
|
2021-06-17 11:38:30 +00:00
|
|
|
(log-syndicate/dataspace-debug "~v + ~v~a" ds-e handle (pretty-assertion 4 value))
|
2021-06-03 13:59:17 +00:00
|
|
|
(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
|
2022-01-16 23:18:57 +00:00
|
|
|
[(? eof-object?)
|
|
|
|
(log-syndicate/dataspace-debug "Not an observer:~a" (pretty-assertion 4 value))
|
|
|
|
(void)]
|
|
|
|
[(Observe pat ref)
|
|
|
|
(add-interest! this-turn skeleton pat ref)
|
|
|
|
(log-syndicate/dataspace-debug "Updated index:~a" (pretty-assertion 4 skeleton))
|
|
|
|
])
|
2021-06-03 13:59:17 +00:00
|
|
|
(add-assertion! this-turn skeleton value)))
|
2021-06-10 09:42:07 +00:00
|
|
|
#:retract (lambda (upstream-handle)
|
2021-06-03 13:59:17 +00:00
|
|
|
(match (hash-ref handles upstream-handle #f)
|
|
|
|
[#f (error 'dataspace "Peer retracted unknown handle ~v" upstream-handle)]
|
|
|
|
[(cons value maybe-observe)
|
2021-06-17 11:38:30 +00:00
|
|
|
(log-syndicate/dataspace-debug "~v - ~v~a" ds-e upstream-handle (pretty-assertion 4 value))
|
2021-06-03 13:59:17 +00:00
|
|
|
(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)]))]))
|
2021-06-10 09:42:07 +00:00
|
|
|
#:message (lambda (message)
|
2021-06-17 11:38:30 +00:00
|
|
|
(log-syndicate/dataspace-debug "~v !~a" ds-e (pretty-assertion 4 message))
|
2021-06-03 13:59:17 +00:00
|
|
|
(send-assertion! this-turn skeleton message))))
|
2021-06-13 05:55:50 +00:00
|
|
|
(ref ds-e))
|
2021-06-03 20:40:51 +00:00
|
|
|
|
2021-06-17 12:57:06 +00:00
|
|
|
(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 ...)]))
|