Timeouts
This commit is contained in:
parent
47a6607981
commit
1d110a1845
|
@ -8,6 +8,7 @@
|
||||||
(require "os-big-bang.rkt")
|
(require "os-big-bang.rkt")
|
||||||
(require "os-udp.rkt")
|
(require "os-udp.rkt")
|
||||||
(require "os-dns.rkt")
|
(require "os-dns.rkt")
|
||||||
|
(require "os-timer.rkt")
|
||||||
|
|
||||||
(provide network-query/addresses)
|
(provide network-query/addresses)
|
||||||
|
|
||||||
|
@ -171,9 +172,14 @@
|
||||||
(udp-address server-host-name server-port)))
|
(udp-address server-host-name server-port)))
|
||||||
(define subscription-id (list s (dns-message-id query)))
|
(define subscription-id (list s (dns-message-id query)))
|
||||||
(list (send-message req)
|
(list (send-message req)
|
||||||
;; TODO: timeout!
|
(send-message (set-timer subscription-id (* timeout 1000) #t))
|
||||||
(subscribe subscription-id
|
(subscribe subscription-id
|
||||||
(message-handlers w
|
(message-handlers w
|
||||||
|
[(timer-expired (== subscription-id) _)
|
||||||
|
(write `(Timed out ,q to ,ns-rr after ,timeout seconds)) (newline)
|
||||||
|
(transition w
|
||||||
|
(unsubscribe subscription-id)
|
||||||
|
(k 'no-answer))]
|
||||||
[(dns-reply reply-message source (== s))
|
[(dns-reply reply-message source (== s))
|
||||||
;; TODO: maybe receive only specifically from the queried IP address?
|
;; TODO: maybe receive only specifically from the queried IP address?
|
||||||
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
|
(if (not (= (dns-message-id reply-message) (dns-message-id query)))
|
||||||
|
|
|
@ -0,0 +1,48 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
(require "codec.rkt")
|
||||||
|
(require "os-big-bang.rkt")
|
||||||
|
(require "os-udp.rkt")
|
||||||
|
|
||||||
|
(provide (struct-out set-timer)
|
||||||
|
(struct-out timer-expired)
|
||||||
|
timer-driver
|
||||||
|
timer-relay)
|
||||||
|
|
||||||
|
(struct set-timer (label msecs relative?) #:prefab)
|
||||||
|
(struct timer-expired (label msecs) #:prefab)
|
||||||
|
|
||||||
|
;; Something like this should be part of racket
|
||||||
|
(define (timer-evt msecs relative?)
|
||||||
|
(wrap-evt (alarm-evt (if relative? (+ (current-inexact-milliseconds) msecs) msecs))
|
||||||
|
(lambda (_) (current-inexact-milliseconds))))
|
||||||
|
|
||||||
|
(define (timer-driver [self-id 'timer-driver])
|
||||||
|
(os-big-bang 'no-state
|
||||||
|
(subscribe 'timer-setter
|
||||||
|
(message-handlers w
|
||||||
|
[(set-timer label msecs relative?)
|
||||||
|
(transition w
|
||||||
|
(subscribe label
|
||||||
|
(ground-message-handler w
|
||||||
|
[((list self-id label)
|
||||||
|
(timer-evt msecs relative?)
|
||||||
|
=> now)
|
||||||
|
(transition w
|
||||||
|
(unsubscribe label)
|
||||||
|
(send-message (timer-expired label now)))])))]))))
|
||||||
|
|
||||||
|
(define (timer-relay [self-id 'timer-relay])
|
||||||
|
(os-big-bang 'no-state
|
||||||
|
(subscribe 'timer-relay
|
||||||
|
(message-handlers w
|
||||||
|
[(set-timer label msecs relative?)
|
||||||
|
(transition w
|
||||||
|
(send-meta-message (set-timer (list self-id label) msecs relative?))
|
||||||
|
(subscribe label
|
||||||
|
(meta-message-handlers w
|
||||||
|
[(timer-expired (list (== self-id) (== label)) now)
|
||||||
|
(transition w
|
||||||
|
(unsubscribe label)
|
||||||
|
(send-message (timer-expired label now)))])))]))))
|
|
@ -16,6 +16,7 @@
|
||||||
(require "os-big-bang.rkt")
|
(require "os-big-bang.rkt")
|
||||||
(require "os-udp.rkt")
|
(require "os-udp.rkt")
|
||||||
(require "os-dns.rkt")
|
(require "os-dns.rkt")
|
||||||
|
(require "os-timer.rkt")
|
||||||
|
|
||||||
;; Instantiated with a collection of trusted roots to begin its
|
;; Instantiated with a collection of trusted roots to begin its
|
||||||
;; searches from. Performs recursive queries. Doesn't yet cache
|
;; searches from. Performs recursive queries. Doesn't yet cache
|
||||||
|
@ -31,6 +32,7 @@
|
||||||
(define boot-server
|
(define boot-server
|
||||||
(os-big-bang 'no-state
|
(os-big-bang 'no-state
|
||||||
;;(spawn dns-spy)
|
;;(spawn dns-spy)
|
||||||
|
(spawn (timer-relay))
|
||||||
(send-meta-message `(request create-server-socket (udp new ,port-number 512)))
|
(send-meta-message `(request create-server-socket (udp new ,port-number 512)))
|
||||||
(subscribe 'wait-for-server-socket
|
(subscribe 'wait-for-server-socket
|
||||||
(meta-message-handlers w
|
(meta-message-handlers w
|
||||||
|
@ -64,6 +66,7 @@
|
||||||
(ground-vm (os-big-bang (void)
|
(ground-vm (os-big-bang (void)
|
||||||
;;(spawn udp-spy)
|
;;(spawn udp-spy)
|
||||||
(spawn udp-driver)
|
(spawn udp-driver)
|
||||||
|
(spawn (timer-driver))
|
||||||
(spawn (nested-vm boot-server)))))
|
(spawn (nested-vm boot-server)))))
|
||||||
|
|
||||||
(define (request-handler zone request client-sock)
|
(define (request-handler zone request client-sock)
|
||||||
|
@ -80,7 +83,7 @@
|
||||||
(define question (and (pair? (dns-message-questions request-message))
|
(define question (and (pair? (dns-message-questions request-message))
|
||||||
(car (dns-message-questions request-message))))
|
(car (dns-message-questions request-message))))
|
||||||
|
|
||||||
(write `(Looking up ,question)) (newline)
|
(write `(Looking up ,question with query id ,(dns-message-id request-message))) (newline)
|
||||||
|
|
||||||
(define (make-reply answers authorities additional)
|
(define (make-reply answers authorities additional)
|
||||||
(dns-message (dns-message-id request-message)
|
(dns-message (dns-message-id request-message)
|
||||||
|
|
Loading…
Reference in New Issue