Fix double-embedded problem; ~working tcp-server!
This commit is contained in:
parent
5c2bdb1e93
commit
eb3aa40541
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue