X-Git-Url: http://dolda2000.com/gitweb/?p=lisp-utils.git;a=blobdiff_plain;f=dns.lisp;h=cfb1750fb5717b4c3e2a310e627bf6a973d226de;hp=f768d2ccbee668df78cf564c530684d252be7c2a;hb=0818ef9996e98050d814f370f4cd3ea22e4bdf9a;hpb=426521e71071782c77c495dee36c853c08babad4

diff --git a/dns.lisp b/dns.lisp
index f768d2c..cfb1750 100644
--- a/dns.lisp
+++ b/dns.lisp
@@ -380,3 +380,61 @@
   (let ((buf (make-dns-encode-state)))
     (encode-dns-packet buf packet)
     (slot-value buf 'packet-buf)))
+
+;;; DN format
+
+(defun parse-domain-name (name)
+  (declare (type string name))
+  (let ((l '())
+	(p 0))
+    (loop (let ((p2 (position #\. name :start p)))
+	    (if p2
+		(if (= p2 (1- (length name)))
+		    (return (values l t))
+		    (setf l (append l (list (subseq name p p2)))
+			  p (1+ p2)))
+		(return (values (append l (list (subseq name p))) nil)))))))
+
+(defun unparse-domain-name (name)
+  (declare (type list name))
+  (let ((buf nil))
+    (dolist (label name buf)
+      (setf buf (if buf
+		    (concatenate 'string buf "." label)
+		    label)))))
+
+;;; Basic communication
+
+(defun dns-do-request (server packet)
+  (declare (type address server)
+	   (type dns-packet packet))
+  (with-connection (sk server)
+    (socket-send sk (dns-encode packet))
+    (loop
+       (let ((resp (dns-decode (socket-recv sk))))
+	 (when (= (dns-packet-txid resp)
+		(dns-packet-txid packet))
+	   (return resp))))))
+
+(defun dns-std-request (queries &key (txid (random 65536)) (recurse t))
+  (let ((qlist (map 'list #'(lambda (o)
+			      (let ((name (first o))
+				    (type (second o)))
+				(make-instance 'resource-query
+					       :name (etypecase name
+						       (string (parse-domain-name name))
+						       (list name))
+					       :type type)))
+		    queries)))
+    (make-dns-packet :txid txid
+		     :recurse recurse
+		     :queries qlist)))
+
+;;; Misc.
+
+(defmethod print-object ((q resource-query) stream)
+  (with-slots (name type) q
+    (if *print-readably*
+	(format stream "~A: ~A" type (unparse-domain-name name))
+	(format stream "#<~S ~S ~S>" 'resource-query type (unparse-domain-name name)))))
+