73 lines
2.4 KiB
Racket
73 lines
2.4 KiB
Racket
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
#lang syndicate
|
|
|
|
(provide (all-defined-out))
|
|
|
|
(require (prefix-in preserves: preserves))
|
|
(require bitsyntax)
|
|
(require (only-in net/rfc6455 ws-idle-timeout))
|
|
(require (only-in racket/list index-of))
|
|
|
|
;; Enrolment
|
|
(message-struct Connect (scope)) ;; Client --> Server
|
|
|
|
;; Transactions
|
|
(message-struct Turn (items)) ;; Bidirectional
|
|
;; Items:
|
|
;; Actions; Client --> Server (and Peer --> Peer, except for Message)
|
|
(message-struct Assert (endpoint-name assertion))
|
|
(message-struct Clear (endpoint-name))
|
|
(message-struct Message (body))
|
|
;; Events; Server --> Client (and Peer --> Peer)
|
|
(message-struct Add (endpoint-name captures))
|
|
(message-struct Del (endpoint-name captures))
|
|
(message-struct Msg (endpoint-name captures))
|
|
(message-struct End (endpoint-name))
|
|
|
|
;; Errors
|
|
(message-struct Err (detail context)) ;; Server --> Client (and Peer --> Peer)
|
|
|
|
;; Transport-related; Bidirectional
|
|
(message-struct Ping ())
|
|
(message-struct Pong ())
|
|
|
|
;; In peer mode, *actions* and *events* travel in *both* directions,
|
|
;; but `Message`s do not appear and (for now) `Assert` is only used to
|
|
;; establish `observe`s, i.e. subscriptions.
|
|
|
|
(define (decode bs)
|
|
(preserves:bytes->preserve bs))
|
|
|
|
(define (encode v)
|
|
(preserves:preserve->bytes v))
|
|
|
|
(define (ping-interval)
|
|
(* 1000 (min 60 ;; reasonable default?
|
|
;;
|
|
;; TODO: disable the net/rfc6455 ws-idle-timeout, when we can.
|
|
;;
|
|
;; The net/rfc6455 ws-idle-timeout has to be paid attention to here because it
|
|
;; can't be disabled, because the built-in webserver (which net/rfc6455
|
|
;; interoperates with) has a per-connection timer that also can't be disabled.
|
|
;;
|
|
(max (- (ws-idle-timeout) 10)
|
|
(* (ws-idle-timeout) 0.8)))))
|
|
|
|
(define (packet-accumulator handle-packet!)
|
|
(field [buffer #""])
|
|
(begin/dataflow
|
|
(define p (open-input-bytes (buffer)))
|
|
(let read-more ()
|
|
(define start-pos (file-position p))
|
|
(match (preserves:read-preserve/binary p #:on-short (lambda () eof))
|
|
[(? eof-object?)
|
|
(when (positive? start-pos)
|
|
(buffer (subbytes (buffer) start-pos)))]
|
|
[packet
|
|
(handle-packet! packet)
|
|
(read-more)])))
|
|
(lambda (chunk)
|
|
(buffer (bytes-append (buffer) chunk))))
|