Fix double-embedded problem; ~working tcp-server!

This commit is contained in:
Tony Garnock-Jones 2021-06-08 18:01:27 +02:00
parent 5c2bdb1e93
commit eb3aa40541
3 changed files with 91 additions and 49 deletions

View File

@ -36,7 +36,9 @@
(spawn-relay
this-turn
#:name name-base
#:packet-writer (lambda (bs) (write-bytes bs o))
#:packet-writer (lambda (bs)
(write-bytes bs o)
(flush-output o))
#:setup-inputs (action (tr)
(on-stop (close-input-port i)

View File

@ -18,7 +18,13 @@
(struct inbound (local-handle imported))
(struct wire-symbol (oid ref [count #:mutable]))
(struct wire-symbol (oid ref [count #:mutable])
#:methods gen:custom-write
[(define (write-proc ws port mode)
(fprintf port "#<wire-symbol:~a/~a ~v>"
(wire-symbol-oid ws)
(wire-symbol-count ws)
(wire-symbol-ref ws)))])
(struct membrane (oid-map ref-map))
@ -144,8 +150,9 @@
(match (parse-Turn packet)
[(? eof-object?) (error 'handle-packet "Invalid IO.Turn")]
[(Turn wire-turn)
(log-info "IN (raw): ~v" packet)
(log-info "IN (parsed): ~v" (Turn wire-turn))
(for [(ev (in-list wire-turn))]
(log-info "~v" ev)
(match-define (TurnEvent (Oid oid) event) ev)
(define r (lookup-local tr oid))
(match event
@ -178,18 +185,22 @@
(for [(ws (in-list imported))]
(drop (tunnel-relay-imported-references tr) ws))))]))])))
(define (send-event tr event)
(define (send-event tr oid event)
(when (null? (tunnel-relay-pending-turn-rev tr))
(queue-task! (actor-engine (facet-actor (tunnel-relay-facet tr)))
(lambda ()
(define pending (reverse (tunnel-relay-pending-turn-rev tr)))
(define pending (Turn (reverse (tunnel-relay-pending-turn-rev tr))))
(set-tunnel-relay-pending-turn-rev! tr '())
(log-info "OUT (parsed): ~v" pending)
(log-info "OUT (raw): ~v" (->preserve pending))
(parse-Turn! (->preserve pending))
((tunnel-relay-packet-writer tr)
(preserve->bytes (->preserve pending)
#:canonicalizing? #t
#:write-annotations? #f
#:encode-embedded encode-embedded:protocol)))))
(set-tunnel-relay-pending-turn-rev! tr (cons event (tunnel-relay-pending-turn-rev tr))))
(set-tunnel-relay-pending-turn-rev! tr (cons (TurnEvent (Oid oid) event)
(tunnel-relay-pending-turn-rev tr))))
(define (rewrite-out tr assertion transient?)
(define exported '())
@ -237,38 +248,48 @@
(hash-remove! (tunnel-relay-outbound-assertions tr) handle))
(define (make-relay-entity tr oid)
(entity #:name (list (tunnel-relay-name tr) oid)
#:assert (action (assertion handle)
(send-event tr (Event-Assert
(Assert (Assertion (register tr assertion handle))
(Handle handle)))))
#:retract (action (handle)
(deregister tr handle)
(send-event tr (Event-Retract (Retract (Handle handle)))))
#:message (action (body)
(send-event tr (Event-Message (Message (Assertion (register tr body #f))))))
#:sync (action (peer)
(define exported #f)
(define (save! ws) (set! exported ws))
(define spe (sync-peer-entity tr oid peer (lambda () exported)))
(send-event tr
(Event-Sync
(entity #:name
(list (tunnel-relay-name tr) oid)
#:assert
(action (assertion handle)
(send-event tr oid (Event-Assert
(Assert (Assertion (register tr assertion handle))
(Handle handle)))))
#:retract
(action (handle)
(deregister tr handle)
(send-event tr oid (Event-Retract (Retract (Handle handle)))))
#:message
(action (body)
(send-event tr oid (Event-Message (Message (Assertion (register tr body #f))))))
#:sync
(action (peer)
(define exported #f)
(define (save! ws) (set! exported ws))
(define spe (sync-peer-entity tr oid peer (lambda () exported)))
(send-event tr oid (Event-Sync
(Sync (rewrite-ref-out tr (turn-ref this-turn spe) #f save!)))))
#:data (relay-entity tr oid)))
#:data
(relay-entity tr oid)))
(define (sync-peer-entity tr oid peer get-export)
(define handle-map (make-hash))
(entity #:name (list (tunnel-relay-name tr) oid 'sync)
#:assert (action (assertion handle)
(hash-set! handle-map handle (turn-assert! this-turn peer assertion)))
#:retract (action (handle)
(turn-retract! this-turn (hash-ref handle-map handle))
(hash-remove! handle-map handle))
#:message (action (body)
(release-ref-out tr (get-export))
(turn-message! this-turn peer body))
#:sync (action (peer-k)
(turn-sync! this-turn peer peer-k))))
(entity #:name
(list (tunnel-relay-name tr) oid 'sync)
#:assert
(action (assertion handle)
(hash-set! handle-map handle (turn-assert! this-turn peer assertion)))
#:retract
(action (handle)
(turn-retract! this-turn (hash-ref handle-map handle))
(hash-remove! handle-map handle))
#:message
(action (body)
(release-ref-out tr (get-export))
(turn-message! this-turn peer body))
#:sync
(action (peer-k)
(turn-sync! this-turn peer peer-k))))
(define (spawn-relay turn
#:packet-writer packet-writer
@ -299,11 +320,3 @@
(sturdy:WireRef-mine
(sturdy:Oid initial-oid))
(lambda (_ws) (void))))))))))
(define-syntax-rule (D v0)
(let ((v v0))
(log-info "~a: ~v" 'v0 v)
v))
(require racket/trace)
(trace rewrite-out)

View File

@ -39,6 +39,29 @@
sym
(format-symbol ":pat:~a" sym)))
(define (final-atom-destructurer pat)
(when (not (SimplePattern? pat))
(error 'final-atom-destructurer "Internal error: got ~v" pat))
(match pat
[(SimplePattern-any) `values]
[(SimplePattern-atom atomKind)
`(lambda (stx) #`(? ,(match atomKind
[(AtomKind-Boolean) `boolean?]
[(AtomKind-Float) `float?]
[(AtomKind-Double) `double-flonum?]
[(AtomKind-SignedInteger) `integer?]
[(AtomKind-String) `string?]
[(AtomKind-ByteString) `bytes?]
[(AtomKind-Symbol) `symbol?])
#,stx))]
[(SimplePattern-embedded _interface)
`(lambda (stx) #`(embedded #,stx))]
[(SimplePattern-lit value) `values]
[(SimplePattern-seqof pat) `values]
[(SimplePattern-setof pat) `values]
[(SimplePattern-dictof key-pat value-pat) `values]
[(SimplePattern-Ref (Ref (ModulePath module-path) name)) `values]))
(define (def-pattern name def)
(define discard `(,(N 'Pattern-DDiscard) (,(N 'DDiscard))))
@ -53,7 +76,7 @@
[(SimplePattern-seqof pat) discard]
[(SimplePattern-setof pat) discard]
[(SimplePattern-dictof key-pat value-pat) discard]
[(SimplePattern-Ref (Ref module-path name))
[(SimplePattern-Ref (Ref (ModulePath module-path) name))
`(:pattern-ref ,(format-symbol "~a~a" (module-path-prefix module-path) name))]
[(CompoundPattern-rec label-pat fields-pat)
(match* ((unwrap label-pat) (unwrap fields-pat))
@ -88,14 +111,16 @@
(define (top-pat top-name name p ty k-nonrecord)
(let ((fields (match ty
[(ty-unit) '()]
[(ty-record fields) (map escape (map ty-field-name fields))]
[(ty-record fields) fields]
[_ #f])))
(if (not fields)
(k-nonrecord)
`(define-preserves-pattern ,top-name (,name ,@fields)
`(define-preserves-pattern ,top-name (,name ,@(map escape (map ty-field-name fields)))
(quasisyntax ,(pat-pattern p))
(append ,@(for/list [(f (in-list fields))]
`(analyse-pattern-bindings (syntax ,f))))))))
`(map ,(final-atom-destructurer (unwrap (ty-field-pattern f)))
(analyse-pattern-bindings
(syntax ,(escape (ty-field-name f)))))))))))
(match def
[(Definition-or p0 p1 pN)
@ -104,9 +129,11 @@
(match-define (NamedAlternative variant-label-str pattern) named-alt)
(define full-name (format-symbol "~a-~a" name variant-label-str))
(top-pat name full-name pattern alt-ty
(lambda () `(define-preserves-pattern ,name (,full-name value)
(analyse-pattern #'value)
(analyse-pattern-bindings (syntax value)))))))]
(lambda ()
`(define-preserves-pattern ,name (,full-name value)
(analyse-pattern #'value)
(map ,(final-atom-destructurer (unwrap pattern))
(analyse-pattern-bindings (syntax value))))))))]
[(? Definition-and?)
`(begin)]
[(Definition-Pattern p)