diff --git a/dns.scm b/dns.scm
new file mode 100644
index 0000000..a9b5963
--- /dev/null
+++ b/dns.scm
@@ -0,0 +1,349 @@
+;; open string-table big-util(?) ascii format signals random
+
+(define *nul* (ascii->char 0))
+(define *on* (ascii->char 1))
+
+(define types
+  '((a 1)
+    (ns 2)
+    (md 3)
+    (mf 4)
+    (cname 5)
+    (soa 6)
+    (mb 7)
+    (mg 8)
+    (mr 9)
+    (null 10)
+    (wks 11)
+    (ptr 12)
+    (hinfo 13)
+    (minfo 14)
+    (mx 15)
+    (txt 16)))
+
+(define classes
+  '((in 1)
+    (cs 2)
+    (ch 3)
+    (hs 4)))
+
+(define (cossa i l)
+  (cond
+   ((null? l) #f)
+   ((equal? (cadar l) i)
+    (car l))
+   (else (cossa i (cdr l)))))
+
+(define (number->octet-pair n)
+  (list (ascii->char (arithmetic-shift n -8))
+	(ascii->char (modulo n 256))))
+
+(define (octet-pair->number a b)
+  (+ (arithmetic-shift (char->ascii a) 8)
+     (char->ascii b)))
+
+(define (octet-quad->number a b c d)
+  (+ (arithmetic-shift (char->ascii a) 24)
+     (arithmetic-shift (char->ascii b) 16)
+     (arithmetic-shift (char->ascii c) 8)
+     (char->ascii d)))
+
+(define (name->octets s)
+  (define (encode-portion s)
+    (cons
+     (ascii->char (string-length s))
+     (string->list s)))
+
+  (let loop ((s s))
+    (cond
+     ((string-match "^([^.]*)\\.(.*)" s)
+      => (lambda (match)
+	   (append
+	    (encode-portion (match:substring match 1))
+	    (loop (match:substring match 2)))))
+     (else
+      (append
+       (encode-portion s)
+       (list *nul*))))))
+
+(define (make-std-query-header id question-count)
+  (append
+   (number->octet-pair id)
+   (list *on* *nul*)			; Opcode & flags (recusive flag set)
+   (number->octet-pair question-count)
+   (number->octet-pair 0)
+   (number->octet-pair 0)
+   (number->octet-pair 0)))
+
+(define (make-query id name type class)
+  (append
+   (make-std-query-header id 1)
+   (name->octets name)
+   (number->octet-pair (cadr (assoc type types)))
+   (number->octet-pair (cadr (assoc class classes)))))
+
+(define (add-size-tag m)
+  (append (number->octet-pair (length m)) m))
+
+(define (rr-data rr)
+  (cadddr (cdr rr)))
+
+(define (rr-type rr)
+  (cadr rr))
+
+(define (rr-name rr)
+  (car rr))
+
+(define (parse-name start reply)
+  (let ((v (char->ascii (car start))))
+    (cond
+     ((zero? v)
+      ;; End of name
+      (values #f (cdr start)))
+     ((zero? (bitwise-and #xc0 v))
+      ;; Normal label
+      (let loop ((len v)
+		 (start (cdr start))
+		 (accum '()))
+	(cond
+	 ((zero? len)
+	  (call-with-values
+	   (lambda () (parse-name start reply))
+	   (lambda (s start)
+	     (let ((s0 (list->string (reverse! accum))))
+	       (values (if s
+			   (string-append s0 "." s)
+			   s0)
+		       start)))))
+	 (else (loop (- len 1)
+		     (cdr start)
+		     (cons (car start) accum))))))
+     (else
+      ;; Compression offset
+      (let ((offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
+		       (char->ascii (cadr start)))))
+	(call-with-values
+	 (lambda () (parse-name (list-tail reply offset) reply))
+	 (lambda (s ignore-start)
+	   (values s (cddr start)))))))))
+
+(define (parse-rr start reply)
+  (call-with-values
+   (lambda () (parse-name start reply))
+   (lambda (name start)
+     (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
+	   (start (cddr start)))
+       (let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
+	     (start (cddr start)))
+	 (let ((ttl (octet-quad->number (car start) (cadr start)
+					(caddr start) (cadddr start)))
+	       (start (cddddr start)))
+	   (let ((len (octet-pair->number (car start) (cadr start)))
+		 (start (cddr start)))
+					; Extract next len bytes for data:
+	     (let loop ((len len)
+			(start start)
+			(accum '()))
+	       (if (zero? len)
+		   (values (list name type class ttl (reverse! accum))
+			   start)
+		   (loop (- len 1)
+			 (cdr start)
+			 (cons (car start) accum)))))))))))
+
+(define (parse-ques start reply)
+  (call-with-values
+   (lambda () (parse-name start reply))
+   (lambda (name start)
+     (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types)))
+	   (start (cddr start)))
+       (let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes)))
+	     (start (cddr start)))
+	 (values (list name type class) start))))))
+
+(define (parse-n parse start reply n)
+  (let loop ((n n) (start start) (accum '()))
+    (if (zero? n)
+	(values (reverse! accum) start)
+	(call-with-values
+	 (lambda () (parse start reply))
+	 (lambda (rr start)
+	   (loop (- n 1) start (cons rr accum)))))))
+
+(define random
+  (let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
+    (lambda (limit)
+      (quotient (* (modulo (crank) 314159265)
+		   limit)
+		314159265))))
+
+(define (dns-query nameserver addr type class)
+  (if (not (assoc type types))
+      (error "dns-query: invalid DNS query type ~a" type))
+  (if (not (assoc class classes))
+      (error "dns-query: invalid DNS query class ~a" class))
+
+  (let* ((query (make-query (random 256) addr type class))
+	 (reply
+	  (let ((socket (socket-connect protocol-family/internet
+					socket-type/stream
+					nameserver 53)))
+	    (let ((r (socket:inport socket))
+		  (w (socket:outport socket)))
+	      (dynamic-wind
+	       (lambda ()
+		 'fick-dich-ins-knie)
+	       (lambda ()
+		 (display (list->string (add-size-tag query)) w)
+		 (force-output w)
+	       
+		 (let ((a (read-char r))
+		       (b (read-char r)))
+		   (let ((len (octet-pair->number a b)))
+		     (let ((s (read-string len r)))
+		       (if (not (= len (string-length s)))
+			   (error "dns-query: unexpected EOF from server"))
+		       (string->list s)))))
+	       (lambda ()
+		 (close-socket socket)))))))
+
+    ;; First two bytes must match sent message id:
+    (if (not (and (char=? (car reply) (car query))
+		  (char=? (cadr reply) (cadr query))))
+	(error "dns-query: bad reply id from server"))
+
+    (let ((v0 (caddr reply))
+	  (v1 (cadddr reply)))
+      ;; Check for error code:
+      (let ((rcode (bitwise-and #xf (char->ascii v1))))
+	(if (not (zero? rcode))
+	    (error "dns-query: error from server: ~a"
+		   (case rcode
+		     ((1) "format error")
+		     ((2) "server failure")
+		     ((3) "name error")
+		     ((4) "not implemented")
+		     ((5) "refused")))))
+	    
+      (let ((qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5)))
+	    (an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7)))
+	    (ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9)))
+	    (ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))))
+	      
+	(let ((start (list-tail reply 12)))
+	  (call-with-values
+	   (lambda () (parse-n parse-ques start reply qd-count))
+	   (lambda (qds start)
+	     (call-with-values
+	      (lambda () (parse-n parse-rr start reply an-count))
+	      (lambda (ans start)
+		(call-with-values
+		 (lambda () (parse-n parse-rr start reply ns-count))
+		 (lambda (nss start)
+		   (call-with-values
+		    (lambda () (parse-n parse-rr start reply ar-count))
+		    (lambda (ars start)
+		      (if (not (null? start))
+			  (error "dns-query: error parsing server reply"))
+		      (values (positive? (bitwise-and #x4 (char->ascii v0)))
+			      qds ans nss ars reply))))))))))))))
+
+(define cache (make-string-table))
+(define (dns-query/cache nameserver addr type class)
+  (let ((key (format #f "~a;~a;~a;~a" nameserver addr type class)))
+    (cond
+     ((table-ref cache key)
+      => (lambda (v)
+	   (apply values v)))
+     (else
+      (call-with-values
+       (lambda () (dns-query nameserver addr type class))
+       (lambda (auth? qds ans nss ars reply)
+	 (table-set! cache key (list auth? qds ans nss ars reply))
+	 (values auth? qds ans nss ars reply)))))))
+
+(define (ip->string s)
+  (format #f
+	  "~a.~a.~a.~a" 
+	  (char->ascii (list-ref s 0))
+	  (char->ascii (list-ref s 1))
+	  (char->ascii (list-ref s 2))
+	  (char->ascii (list-ref s 3))))
+
+(define (try-forwarding k nameserver)
+  (let loop ((nameserver nameserver)
+	     (tried (list nameserver)))
+    ;; Normally the recursion is done for us, but it's technically optional
+    (call-with-values
+     (lambda () (k nameserver))
+     (lambda (v ars auth?)
+       (or v
+	   (and (not auth?)
+		(let* ((ns (any
+			    (lambda (ar)
+			      (and (eq? (rr-type ar) 'a)
+				   (ip->string (rr-data ar))))
+			    ars)))
+		  (and ns
+		       (not (member ns tried))
+		       (loop ns (cons ns tried))))))))))
+
+(define (dns-get-address nameserver addr)
+  (or (try-forwarding
+       (lambda (nameserver)
+	 (call-with-values
+	  (lambda () (dns-query/cache nameserver addr 'a 'in))
+	  (lambda (auth? qds ans nss ars reply)
+	    (values (and (positive? (length ans))
+			 (let ((s (rr-data (car ans))))
+			   (ip->string s)))
+		    ars auth?))))
+       nameserver)
+      (error "dns-get-address: bad address ~a" addr)))
+
+(define (dns-get-mail-exchanger nameserver addr)
+  (or (try-forwarding
+       (lambda (nameserver)
+	 (call-with-values
+	  (lambda () (dns-query/cache nameserver addr 'mx 'in))
+	  (lambda (auth? qds ans nss ars reply)
+	    (values (let loop ((ans ans)
+			       (best-pref 99999) ; this is enough
+			       (exchanger #f))
+		      (cond
+		       ((null? ans)
+			(or exchanger
+			    ;; Does 'soa mean that the input address is fine?
+			    (and (any? (lambda (ns)
+					 (eq? (rr-type ns) 'soa))
+				       nss)
+				 addr)))
+		       (else
+			(let ((d (rr-data (car ans))))
+			  (let ((pref (octet-pair->number (car d) (cadr d))))
+			    (if (< pref best-pref)
+				(call-with-values
+				 (lambda () (parse-name (cddr d) reply))
+				 (lambda (name start)
+				   (loop (cdr ans) pref name)))
+				(loop (cdr ans) best-pref exchanger)))))))
+		    ars auth?))))
+       nameserver)
+      (error "dns-get-mail-exchanger: bad address")))
+
+(define (dns-find-nameserver)
+  (with-input-from-file "/etc/resolv.conf"
+    (lambda ()
+      (let loop ()
+	(let ((l (read-line)))
+	  (cond
+	   ((eof-object? l)
+	    #f)
+	   ((string-match "nameserver[ 	]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)"
+			  l)
+	    => (lambda (match)
+		 (match:substring match 1)))
+	   (else
+	    (loop))))))))
+
+
diff --git a/modules.scm b/modules.scm
index 44f864d..ed7dfac 100644
--- a/modules.scm
+++ b/modules.scm
@@ -699,3 +699,18 @@
     (define (eval-safely exp)
       (ignore-errors (lambda () (eval exp (new-safe-package)))))))
 
+(define-interface dns-interface
+  (export dns-get-address
+	  dns-get-mail-exchanger
+	  dns-find-nameserver))
+
+(define-structure dns dns-interface
+  (open scheme
+	scsh
+	big-util
+	tables
+	ascii
+	formats
+	signals
+	random)
+  (files dns))