Timeouts

network-query.rkt

@@ -8,6 +8,7 @@
 (require "os-big-bang.rkt")
 (require "os-udp.rkt")
 (require "os-dns.rkt")
+(require "os-timer.rkt")
 
 (provide network-query/addresses)
 
@@ -171,9 +172,14 @@
 			   (udp-address server-host-name server-port)))
   (define subscription-id (list s (dns-message-id query)))
   (list (send-message req)
-	;; TODO: timeout!
+	(send-message (set-timer subscription-id (* timeout 1000) #t))
 	(subscribe subscription-id
 		   (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))
 		     ;; TODO: maybe receive only specifically from the queried IP address?
 		     (if (not (= (dns-message-id reply-message) (dns-message-id query)))

os-timer.rkt

@@ -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)))])))]))))

proxy.rkt

@@ -16,6 +16,7 @@
 (require "os-big-bang.rkt")
 (require "os-udp.rkt")
 (require "os-dns.rkt")
+(require "os-timer.rkt")
 
 ;; Instantiated with a collection of trusted roots to begin its
 ;; searches from. Performs recursive queries. Doesn't yet cache
@@ -31,6 +32,7 @@
   (define boot-server
     (os-big-bang 'no-state
 		 ;;(spawn dns-spy)
+		 (spawn (timer-relay))
 		 (send-meta-message `(request create-server-socket (udp new ,port-number 512)))
 		 (subscribe 'wait-for-server-socket
 			    (meta-message-handlers w
@@ -64,6 +66,7 @@
   (ground-vm (os-big-bang (void)
 			  ;;(spawn udp-spy)
 			  (spawn udp-driver)
+			  (spawn (timer-driver))
 			  (spawn (nested-vm boot-server)))))
 
 (define (request-handler zone request client-sock)
@@ -80,7 +83,7 @@
   (define question (and (pair? (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)
     (dns-message (dns-message-id request-message)