Make handlers etc *required* to return a transition structure.
This commit is contained in:
parent
bfab626708
commit
345965e473
|
@ -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)
|
||||||
|
|
18
os2-dns.rkt
18
os2-dns.rkt
|
@ -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
10
proxy.rkt
|
@ -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)
|
||||||
|
|
Loading…
Reference in New Issue