cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

commit 2697b4ec6deceeea0bc3df73a8c598a2ad35c5aa
parent 33b17eb0e4d3a5d7505944c9a86410d20baace6f
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sun, 14 Dec 2014 17:46:43 +0100

more dns

Diffstat:
Mdns.lisp | 152++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-----------
Msocket.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)