syndicate-lang
/
racket-dns-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Switch back to returning transitions rather than actions, to permit control over debug-names

This commit is contained in:
Tony Garnock-Jones 2013-03-20 11:00:23 -04:00
parent 5da7f0ac15
commit bd32469757
2 changed files with 44 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
driver.rkt
View File

@ -43,9 +43,9 @@
(ground-vm: ((inst udp-driver Void))
((inst generic-spy Void) 'UDP)
(nested-vm: : Void
((inst dns-spy Void))
((inst dns-read-driver Void) local-addr)
((inst dns-write-driver Void) local-addr)
(spawn: #:parent : Void #:child : Void (dns-spy))
(spawn: #:parent : Void #:child : Void (dns-read-driver local-addr))
(spawn: #:parent : Void #:child : Void (dns-write-driver local-addr))
(endpoint: : Void #:subscriber (bad-dns-packet (wild) (wild) (wild) (wild))
[p (begin (log-error (pretty-format p))
'())])

88
tk-dns.rkt
View File

@ -55,27 +55,25 @@
(U Wild UdpAddressPattern))
DNSReplyPattern dns-reply-pattern dns-reply-pattern?)
(: dns-read-driver : (All (ParentState) UdpAddress -> (Action ParentState)))
(: dns-read-driver : UdpAddress -> (Transition Void))
(define (dns-read-driver s)
(spawn: #:parent : ParentState
#:child : Void
(transition: (void) : Void
(at-meta-level
(endpoint: : Void
#:subscriber (udp-packet-pattern (wild) s (wild))
[(udp-packet source (== s) #"")
(begin (log-info "Debug dump packet received")
(send-message `(debug-dump)))]
[(udp-packet source (== s) body)
(send-message
(with-handlers ((exn:fail? (lambda (e)
(bad-dns-packet body source s 'unparseable))))
(define message (packet->dns-message body))
(case (dns-message-direction message)
((request) (dns-request message source s))
((response) (dns-reply message source s)))))])))))
(transition: (void) : Void
(at-meta-level
(endpoint: : Void
#:subscriber (udp-packet-pattern (wild) s (wild))
[(udp-packet source (== s) #"")
(begin (log-info "Debug dump packet received")
(send-message `(debug-dump)))]
[(udp-packet source (== s) body)
(send-message
(with-handlers ((exn:fail? (lambda (e)
(bad-dns-packet body source s 'unparseable))))
(define message (packet->dns-message body))
(case (dns-message-direction message)
((request) (dns-request message source s))
((response) (dns-reply message source s)))))]))))
(: dns-write-driver : (All (ParentState) UdpAddress -> (Action ParentState)))
(: dns-write-driver : UdpAddress -> (Transition Void))
(define (dns-write-driver s)
(: translate : DNSMessage UdpAddress -> (ActionTree Void))
(define (translate message sink)
@ -83,33 +81,29 @@
(send-message (bad-dns-packet message s sink 'unencodable)))))
(at-meta-level
(send-message (udp-packet s sink (dns-message->packet message))))))
(spawn: #:parent : ParentState
#:child : Void
(transition: (void) : Void
(endpoint: : Void
#:subscriber (dns-request (wild) s (wild))
[(dns-request message (== s) sink) (translate message sink)])
(endpoint: : Void
#:subscriber (dns-reply (wild) s (wild))
[(dns-reply message (== s) sink) (translate message sink)]))))
(transition: (void) : Void
(endpoint: : Void
#:subscriber (dns-request (wild) s (wild))
[(dns-request message (== s) sink) (translate message sink)])
(endpoint: : Void
#:subscriber (dns-reply (wild) s (wild))
[(dns-reply message (== s) sink) (translate message sink)])))
(: dns-spy : (All (ParentState) -> (Action ParentState)))
(: dns-spy : -> (Transition Void))
(define (dns-spy)
(spawn: #:parent : ParentState
#:child : Void
(transition: (void) : Void
(endpoint: : Void
#:subscriber (wild) #:observer
[(dns-request message source sink)
(begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v"
source sink (dns-message-id message)
(dns-message-questions message)))
(void))]
[(dns-reply message source sink)
(begin (log-info (format "DNS: ~v answers ~v~n : ~v"
source sink
message))
(void))]
[x
(begin (log-info (format "DNS: ~v" x))
(void))]))))
(transition: (void) : Void
(endpoint: : Void
#:subscriber (wild) #:observer
[(dns-request message source sink)
(begin (log-info (format "DNS: ~v asks ~v ~v~n : ~v"
source sink (dns-message-id message)
(dns-message-questions message)))
(void))]
[(dns-reply message source sink)
(begin (log-info (format "DNS: ~v answers ~v~n : ~v"
source sink
message))
(void))]
[x
(begin (log-info (format "DNS: ~v" x))
(void))])))