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

Make handlers etc *required* to return a transition structure.

This commit is contained in:
Tony Garnock-Jones 2012-07-23 17:21:31 -04:00
parent bfab626708
commit 345965e473
3 changed files with 18 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
network-query.rkt
View File

@ -333,7 +333,7 @@
(dns-message-authorities reply-message) (dns-message-authorities reply-message)
(dns-message-additional reply-message))) (dns-message-additional reply-message)))
(if (not (= (dns-message-id reply-message) (dns-message-id query))) (if (not (= (dns-message-id reply-message) (dns-message-id query)))
w (transition w)
(sequence-actions (on-answer w (sequence-actions (on-answer w
(filter-dns-reply q reply-message zone-origin) (filter-dns-reply q reply-message zone-origin)
server-ip) server-ip)

28
os2-dns.rkt
View File

@ -22,18 +22,16 @@
(transition 'no-state (transition 'no-state
(at-meta-level (at-meta-level
(role (topic-subscriber (udp-packet (wild) s (wild))) (role (topic-subscriber (udp-packet (wild) s (wild)))
#:state w
[(udp-packet source (== s) #"") [(udp-packet source (== s) #"")
(log-info "Debug dump packet received") (log-info "Debug dump packet received")
(transition w (send-message `(debug-dump)))] (send-message `(debug-dump))]
[(udp-packet source (== s) body) [(udp-packet source (== s) body)
(transition w (send-message
(send-message (with-handlers ((exn:fail? (lambda (e) (bad-dns-packet body source s 'unparseable))))
(with-handlers ((exn:fail? (lambda (e) (bad-dns-packet body source s 'unparseable)))) (define message (packet->dns-message body))
(define message (packet->dns-message body)) (case (dns-message-direction message)
(case (dns-message-direction message) ((request) (dns-request message source s))
((request) (dns-request message source s)) ((response) (dns-reply message source s)))))]))))
((response) (dns-reply message source s))))))]))))
(define (dns-write-driver s) (define (dns-write-driver s)
(define (translate message sink) (define (translate message sink)
@ -44,24 +42,22 @@
(transition 'no-state (transition 'no-state
(role (set (topic-subscriber (dns-request (wild) s (wild))) (role (set (topic-subscriber (dns-request (wild) s (wild)))
(topic-subscriber (dns-reply (wild) s (wild)))) (topic-subscriber (dns-reply (wild) s (wild))))
#:state w [(dns-request message (== s) sink) (translate message sink)]
[(dns-request message (== s) sink) (transition w (translate message sink))] [(dns-reply message (== s) sink) (translate message sink)])))
[(dns-reply message (== s) sink) (transition w (translate message sink))])))
(define dns-spy (define dns-spy
(transition 'none (transition 'none
(role (topic-subscriber (wild) #:monitor? #t) (role (topic-subscriber (wild) #:monitor? #t)
#:state w
[(dns-request message source sink) [(dns-request message source sink)
(log-info (format "DNS: ~v asks ~v ~v~n : ~v" (log-info (format "DNS: ~v asks ~v ~v~n : ~v"
source sink (dns-message-id message) source sink (dns-message-id message)
(dns-message-questions message))) (dns-message-questions message)))
w] (void)]
[(dns-reply message source sink) [(dns-reply message source sink)
(log-info (format "DNS: ~v answers ~v~n : ~v" (log-info (format "DNS: ~v answers ~v~n : ~v"
source sink source sink
message)) message))
w] (void)]
[x [x
(log-info (format "DNS: ~v" x)) (log-info (format "DNS: ~v" x))
w]))) (void)])))

10
proxy.rkt
View File

@ -75,7 +75,7 @@
[p [p
(log-error (pretty-format p)) (log-error (pretty-format p))
;; TODO: ^ perhaps use metalevel events? perhaps don't bother though ;; TODO: ^ perhaps use metalevel events? perhaps don't bother though
old-active-requests]) (transition old-active-requests)])
(role (topic-subscriber (dns-request (wild) (wild) s)) (role (topic-subscriber (dns-request (wild) (wild) s))
#:state old-active-requests #:state old-active-requests
[(and r (dns-request m source (== s))) ;; We only listen for requests on our server socket [(and r (dns-request m source (== s))) ;; We only listen for requests on our server socket
@ -83,14 +83,14 @@
;; TODO: when we have presence/error-handling, remove req-id ;; TODO: when we have presence/error-handling, remove req-id
;; from active requests once request-handler pseudothread exits. ;; from active requests once request-handler pseudothread exits.
(if (set-member? old-active-requests req-id) (if (set-member? old-active-requests req-id)
old-active-requests ;; ignore retransmitted duplicates (transition old-active-requests) ;; ignore retransmitted duplicates
(transition (set-add old-active-requests req-id) (transition (set-add old-active-requests req-id)
(spawn (packet-relay req-id r) #:debug-name (list 'packet-relay req-id))))]) (spawn (packet-relay req-id r) #:debug-name (list 'packet-relay req-id))))])
(role (topic-subscriber (dns-reply (wild) s (wild))) (role (topic-subscriber (dns-reply (wild) s (wild)))
#:state old-active-requests #:state old-active-requests
[(and r (dns-reply m (== s) sink)) [(and r (dns-reply m (== s) sink))
(define req-id (active-request sink (dns-message-id m))) (define req-id (active-request sink (dns-message-id m)))
(set-remove old-active-requests req-id)]))) (transition (set-remove old-active-requests req-id))])))
(define (packet-relay req-id request) (define (packet-relay req-id request)
(match-define (dns-request request-message request-source request-sink) request) (match-define (dns-request request-message request-source request-sink) request)
@ -190,7 +190,7 @@
(pretty-write current-ground-transition)) (pretty-write current-ground-transition))
#:mode 'text #:mode 'text
#:exists 'append) #:exists 'append)
zone]) (transition zone)])
(role (topic-subscriber (question (wild) (wild) (wild) (wild))) (role (topic-subscriber (question (wild) (wild) (wild) (wild)))
#:state zone #:state zone
[(? question? q) [(? question? q)
@ -214,7 +214,7 @@
(role (topic-subscriber (timer-expired (list 'check-dns-expiry (wild)) (wild))) (role (topic-subscriber (timer-expired (list 'check-dns-expiry (wild)) (wild)))
#:state zone #:state zone
[(timer-expired (list 'check-dns-expiry name) now-msec) [(timer-expired (list 'check-dns-expiry name) now-msec)
(zone-expire-name zone name (/ now-msec 1000.0))]))) (transition (zone-expire-name zone name (/ now-msec 1000.0)))])))
(struct question-state (zone q client-sock nameservers-tried retry-count) #:prefab) (struct question-state (zone q client-sock nameservers-tried retry-count) #:prefab)
(struct expanding-cnames (q accumulator remaining-count) #:prefab) (struct expanding-cnames (q accumulator remaining-count) #:prefab)