;; 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))))))))