commit 2697b4ec6deceeea0bc3df73a8c598a2ad35c5aa
parent 33b17eb0e4d3a5d7505944c9a86410d20baace6f
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 14 Dec 2014 17:46:43 +0100
more dns
Diffstat:
| M | dns.lisp | | | 152 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----------- |
| M | socket.lisp | | | 51 | +++++++++++++++++++++++++++++++++++++++++++++------ |
2 files changed, 176 insertions(+), 27 deletions(-)
diff --git a/dns.lisp b/dns.lisp
@@ -27,6 +27,10 @@
(in-package :rw.dns)
;;https://www.ietf.org/rfc/rfc1035.txt
+;;https://en.wikipedia.org/wiki/Punycode
+;;https://www.iana.org/domains/root/files
+;;http://www.internic.net/domain/named.root
+;;http://www.internic.net/domain/root.zone
(defvar *name-from-position*)
@@ -88,14 +92,14 @@
(map nil (lambda (x) (rw:write-u8 writer x)) x))
(defun next-$ipv6-address (reader)
- (vector (rw:next-u16 reader)
- (rw:next-u16 reader)
- (rw:next-u16 reader)
- (rw:next-u16 reader)
- (rw:next-u16 reader)
- (rw:next-u16 reader)
- (rw:next-u16 reader)
- (rw:next-u16 reader)))
+ (vector (rw:next-u16be reader)
+ (rw:next-u16be reader)
+ (rw:next-u16be reader)
+ (rw:next-u16be reader)
+ (rw:next-u16be reader)
+ (rw:next-u16be reader)
+ (rw:next-u16be reader)
+ (rw:next-u16be reader)))
(defun write-$ipv6-address (writer x)
(assert (= 8 (length x)))
@@ -181,7 +185,6 @@
($type type)
($class class)
(rw:u32be ttl)
- #+nil(rw:u8 data :length rw:u16be)
((ecase type
(A $ipv4-address)
(AAAA $ipv6-address)
@@ -205,7 +208,7 @@
(rw.wire:defstruc $message ()
(rw:u16be tid)
- (rw:u16be flags)
+ (rw:u16be flags) ;; TODO decode flags
(rw:u16be nquestion)
(rw:u16be nanswer)
(rw:u16be nauthority)
@@ -230,7 +233,7 @@
(let ((*name-from-position* #'cb))
(next-$message (rw:shorter-reader (rw:reader b) len))))))))
-(defun query (name server &key (type 'A) (class 'IN) (port 53))
+(defun query1 (name server &key (type 'A) (class 'IN) (port 53))
(let* ((n 512) ;; TODO minus IP/UDP headers
(b (rw.wire::make-octet-buffer n)))
(write-$message
@@ -249,18 +252,125 @@
(assert (<= (length b) n)) ;; TODO dns over tcp
(udp b server port)))
-;;(print (query "mx1.logand.com" #+ccl "8.8.8.8" #-ccl #(8 8 8 8)))
-;;(print (query "seznam.cz" #+ccl "8.8.8.8" #-ccl #(8 8 8 8)))
-;;(print (query "seznam.cz" #(192 168 1 1)))
-;;(print (query "www.google.com" #(8 8 8 8)))
+;;(print (query1 "mx1.logand.com" #(8 8 8 8)))
+;;(print (query1 "mx1.logand.com" "8.8.8.8"))
+
+;;(print (query1 "mx1.logand.com" #(8 8 8 8)))
+;;(print (query1 "seznam.cz" #(8 8 8 8)))
+;;(print (query1 "seznam.cz" #(192 168 1 1)))
+;;(print (query1 "www.google.com" #(8 8 8 8)))
+
+;;(print (query1 "mx1.logand.com" #(8 8 8 8) :type 'NS))
+;;(print (query1 "www.google.com" #(8 8 8 8) :type 'AAAA))
+
+;;(print (query1 "mx1.logand.com" #(8 8 8 8) :type 'MX))
+;;(print (query1 "seznam.cz" #(8 8 8 8) :type 'MX))
+;;(print (query1 "www.google.com" #(8 8 8 8) :type 'MX)) ;; TODO SOA follow authoritative nameservers
+
+;;; how to resolve logand.com?
+;;; logand.com? com logand.com nserv0.domainexpress.co.uk
+;;(print (query1 "com" #(8 8 8 8) :type 'A))
+;;(print (query1 "a.gtld-servers.net" #(8 8 8 8) :type 'A))
+;;(print (query1 "logand.com" #(192 5 6 30) :type 'A))
+;;(print (query1 "uk" #(192 5 6 30) :type 'A))
+
+;;(print (query1 "www.google.com" #(8 8 8 8) :type 'MX))
+;;(print (query1 "ns1.google.com" #(8 8 8 8) :type 'A)) ;; -> #(216 239 32 10)
+;;(print (query1 "www.google.com" #(216 239 32 10) :type 'MX))
+;;(print (query1 "google.com" #(216 239 32 10) :type 'MX))
+
+;;(print (query1 "logand.com" #(8 8 8 8) :type 'MX))
+;;(print (query1 "mx1.logand.com" #(8 8 8 8) :type 'A))
+;;(print (query1 "com" #(8 8 8 8)))
+
+(defvar *cache* (make-hash-table :test #'equal)) ;; TODO locking?
+
+(defstruct cached time ttl data)
+
+(defun validp (cached)
+ (<= (get-universal-time) (+ (cached-time cached) (cached-ttl cached))))
+
+(defun lookup (name type class)
+ (let ((k (list name type class))
+ (n 0)
+ (i 0))
+ (dolist (v (gethash k *cache*))
+ (incf n)
+ (when (validp v)
+ (incf i)))
+ (cond ;; validp?
+ ((<= n i)) ;; everything
+ ((< 0 i) ;; some
+ (setf (gethash k *cache*) (delete-if-not 'validp (gethash k *cache*))))
+ (t ;; none
+ (remhash k *cache*)))
+ (mapcar 'cached-data (gethash k *cache*))))
+
+(defun remember (resource) ;; TODO preserve original ordering?
+ ;; TODO cca pushnew?
+ (push (make-cached :time (get-universal-time)
+ :ttl ($resource-ttl resource)
+ :data ($resource-data resource))
+ (gethash (list ($resource-name resource)
+ ($resource-type resource)
+ ($resource-class resource))
+ *cache*)))
+
+(defun query (name server &key (type 'A) (class 'IN) (port 53))
+ (clrhash *cache*) ;; TODO remove
+ (let ((i 0))
+ (labels
+ ((rec (name type server)
+ (or (lookup name type class)
+ (let* ((q (query1 name server :type type :class class :port port))
+ (answer ($message-answer q))
+ (authority ($message-authority q)))
+ (incf i)
+ (map nil #'remember answer)
+ (map nil #'remember authority)
+ (map nil #'remember ($message-additional q))
+ (cond
+ (answer
+ (or (lookup name type class)
+ (unless (eq 'CNAME type)
+ (loop
+ for x in (rec name 'CNAME server)
+ appending (rec x type server)))))
+ (authority
+ (dolist (a authority)
+ (ecase ($resource-type a)
+ (NS
+ (dolist (server (rec ($resource-data a) type server))
+ (let ((z (rec name type server)))
+ (when z
+ (return-from rec z)))))
+ (SOA (return-from rec nil))))))))))
+ (values (rec name type server) i))))
+
+;;(query "logand.com" #(8 8 8 8) :type 'MX)
+;;(query "mx1.logand.com" #(8 8 8 8) :type 'A)
+;;(query "mx1.logand.com" #(8 8 8 8) :type 'CNAME)
+;;(query "logand.com" #(8 8 8 8) :type 'SOA)
+
+;;(query "google.com" #(8 8 8 8) :type 'AAAA)
+;;(query "google.com" #(8 8 8 8) :type 'A)
+;;(query "google.com" #(8 8 8 8) :type 'MX)
+;;(query "google.com" #(8 8 8 8) :type 'NS)
+;;(query "google.com" #(8 8 8 8) :type 'SOA)
+
+;;(query "google.com" #(8 8 8 8) :type 'CNAME)
+;;(query "google.com" #(8 8 8 8) :type 'PTR)
+;;(query "mx1.logand.com" #(8 8 8 8) :type 'AAAA)
+;;(query "82.192.70.8" #(8 8 8 8) :type 'PTR)
+
+;;(query "google.com" #(8 8 8 8) :type 'TXT)
+;;(query "google.com" #(8 8 8 8) :type 'WKS)
-;;(print (query "mx1.logand.com" #(8 8 8 8) :type 'NS))
-;;(print (query "www.google.com" #(8 8 8 8) :type 'AAAA))
+;;(query "google.com" #(198 41 0 4) :type 'A)
+;;(query "mx1.logand.com" #(198 41 0 4) :type 'A)
-;;(print (query "mx1.logand.com" #(8 8 8 8) :type 'MX))
-;;(print (query "seznam.cz" #(8 8 8 8) :type 'MX))
-;;(print (query "www.google.com" #(8 8 8 8) :type 'MX)) ;; TODO SOA follow authoritative nameservers
-;;(print (query "com" #(8 8 8 8) :type 'A))
+;; TODO root hints http://technet.microsoft.com/en-us/library/cc758353(v=ws.10).aspx
+;; TODO reverse dns
#+nil ;; TODO dns over tcp doesnt seem to work, depends on server?
(defun tcp-query (name server &key (port 53))
diff --git a/socket.lisp b/socket.lisp
@@ -33,6 +33,44 @@
(in-package :rw.socket)
+(defun native-address (x)
+ (when x
+ (etypecase x
+ (string
+ #-ccl
+ (let ((r (rw:peek-reader (rw:reader x))))
+ (vector (rw:next-z0 r)
+ (progn
+ (assert (eql #\. (rw:next r)))
+ (rw:next-z0 r))
+ (progn
+ (assert (eql #\. (rw:next r)))
+ (rw:next-z0 r))
+ (progn
+ (assert (eql #\. (rw:next r)))
+ (rw:next-z0 r))))
+ #+ccl
+ x)
+ (vector
+ #-ccl
+ x
+ #+ccl
+ (with-output-to-string (s)
+ (loop
+ for e across x
+ for i from 0
+ do (progn
+ (assert (< i 4))
+ (assert (<= 0 e 255))
+ (when (plusp i)
+ (write-char #\. s))
+ (format s "~d" e)))))
+ (list (native-address (coerce x 'vector))))))
+
+;;(native-address #(127 0 0 1))
+;;(native-address '(127 0 0 1))
+;;(native-address "127.0.0.1")
+
(defun close-socket (socket)
#-(or ccl ecl sbcl)
(error "TODO port RW.SOCKET::CLOSE-SOCKET")
@@ -71,7 +109,7 @@
:address-family :internet
:type :stream
:format :bivalent ;; TODO :binary
- :local-host local-host
+ :local-host (native-address local-host)
:local-port local-port
:reuse-address t))
@@ -96,7 +134,7 @@
:address-family :internet
:type :stream
:format :bivalent ;; TODO :binary
- :remote-host remote-host
+ :remote-host (native-address remote-host)
:remote-port remote-port))
(defun make-udp-socket (&key local-host local-port remote-host remote-port)
@@ -107,9 +145,9 @@
#+ccl
(ccl:make-socket :address-family :internet
:type :datagram
- :local-host local-host
+ :local-host (native-address local-host)
:local-port local-port
- :remote-host remote-host
+ :remote-host (native-address remote-host)
:remote-port remote-port)
#+(or ecl sbcl)
(let ((x (make-instance 'sb-bsd-sockets:inet-socket
@@ -152,11 +190,12 @@
(error "TODO port RW.SOCKET:UDP-SEND")
#+ccl
(ccl:send-to socket buf len
- :remote-host remote-host
+ :remote-host (native-address remote-host)
:remote-port remote-port)
#+(or ecl sbcl)
(sb-bsd-sockets:socket-send socket buf len
- :address (list remote-host remote-port)))
+ :address (list (native-address remote-host)
+ remote-port)))
(defun udp-receive (socket buf len)
#-(or ccl ecl sbcl)
