From 3d6cdda23b055a04be1f73087eee0c027cd38345 Mon Sep 17 00:00:00 2001 From: "hechee@blackhole.universe.org" <> Date: Tue, 1 Aug 2006 22:56:33 +0200 Subject: [PATCH] Added DNS resolver: basic support for queries. --- iolib.asd | 3 +- protocols/dns-client/dns-constants.lisp | 75 +++++++++++ protocols/dns-client/dns-query.lisp | 220 +++++++++++++++++++++++++++++++ protocols/dns-client/dns-response.lisp | 26 ++++ protocols/dns-client/dynamic-buffer.lisp | 100 ++++++++++++++ protocols/dns-client/export.lisp | 26 ++++ protocols/dns-client/net.dns-client.asd | 21 +++ 7 files changed, 470 insertions(+), 1 deletion(-) create mode 100644 protocols/dns-client/dns-constants.lisp create mode 100644 protocols/dns-client/dns-query.lisp create mode 100644 protocols/dns-client/dns-response.lisp create mode 100644 protocols/dns-client/dynamic-buffer.lisp create mode 100644 protocols/dns-client/export.lisp create mode 100644 protocols/dns-client/net.dns-client.asd diff --git a/iolib.asd b/iolib.asd index e3ae29b..f14e28e 100644 --- a/iolib.asd +++ b/iolib.asd @@ -23,4 +23,5 @@ :maintainer "Stelian Ionescu " :licence "GPL-2.1" :depends-on (#:iolib-alien-ng - #:net.sockets)) + #:net.sockets + #:net.dns-client)) diff --git a/protocols/dns-client/dns-constants.lisp b/protocols/dns-client/dns-constants.lisp new file mode 100644 index 0000000..07ffac6 --- /dev/null +++ b/protocols/dns-client/dns-constants.lisp @@ -0,0 +1,75 @@ +;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Copyright (C) 2006 by Stelian Ionescu ; +; ; +; This program is free software; you can redistribute it and/or modify ; +; it under the terms of the GNU General Public License as published by ; +; the Free Software Foundation; either version 2 of the License, or ; +; (at your option) any later version. ; +; ; +; This program is distributed in the hope that it will be useful, ; +; but WITHOUT ANY WARRANTY; without even the implied warranty of ; +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; +; GNU General Public License for more details. ; +; ; +; You should have received a copy of the GNU General Public License ; +; along with this program; if not, write to the ; +; Free Software Foundation, Inc., ; +; 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2))) +(declaim (optimize (speed 0) (safety 2) (space 0) (debug 2))) + +(in-package #:net.sockets) + +(define-constant +opcode-standard+ 0) + +(define-constant +query-type-map + '((:a . 1) + (:ns . 2) + (:cname . 5) + (:soa . 6) + (:wks . 11) + (:ptr . 12) + (:hinfo . 13) + (:mx . 15) + (:txt . 16) + (:aaaa . 28) + (:any . 255))) + +(defun query-type-number (id) + (cdr (assoc id +query-type-map))) + +(defun query-type-id (number) + (car (rassoc number +query-type-map))) + +(defun valid-type-p (id) + (query-type-number id)) + +(define-constant +query-class-map + '((:in . 1) + (:any . 255))) + +(defun query-class-number (id) + (cdr (assoc id +query-class-map))) + +(defun query-class-id (number) + (car (rassoc number +query-class-map))) + +(define-constant +rcode-map + '((:no-error . 0) + (:format-error . 1) + (:server-failure . 2) + (:name-error . 3) + (:not-implemented . 4) + (:refused . 5))) + +(defun rcode-number (id) + (cdr (assoc id +rcode-map))) + +(defun rcode-id (number) + (car (rassoc number +rcode-map))) + +(define-constant +dns-datagram-size+ 512) diff --git a/protocols/dns-client/dns-query.lisp b/protocols/dns-client/dns-query.lisp new file mode 100644 index 0000000..908c0df --- /dev/null +++ b/protocols/dns-client/dns-query.lisp @@ -0,0 +1,220 @@ +;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Copyright (C) 2006 by Stelian Ionescu ; +; ; +; This program is free software; you can redistribute it and/or modify ; +; it under the terms of the GNU General Public License as published by ; +; the Free Software Foundation; either version 2 of the License, or ; +; (at your option) any later version. ; +; ; +; This program is distributed in the hope that it will be useful, ; +; but WITHOUT ANY WARRANTY; without even the implied warranty of ; +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; +; GNU General Public License for more details. ; +; ; +; You should have received a copy of the GNU General Public License ; +; along with this program; if not, write to the ; +; Free Software Foundation, Inc., ; +; 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2))) +(declaim (optimize (speed 0) (safety 2) (space 0) (debug 2))) + +(in-package #:net.sockets) + +(defparameter *dns-recursion-desired* t) + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; CLASS DEFINITIONS ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass dns-nameserver () + ((name :initarg :name :accessor dns-nameserver-name) + (address :initarg :address :accessor dns-addressserver-address) + (sent :initarg :sent :accessor dns-sentserver-sent) + (received :initarg :received :accessor dns-receivedserver-received))) + +(defclass dns-message () + ((id :initform 0 + :initarg :id :accessor dns-message-id) + (flags :initform 0 + :initarg :flags :accessor dns-message-flags) + (question :initform nil + :initarg :question :accessor dns-message-question) + (answer :initform (make-array 1 :adjustable t :fill-pointer 0) + :initarg :answer :accessor dns-message-answer) + (authority :initform (make-array 1 :adjustable t :fill-pointer 0) + :initarg :authority :accessor dns-message-authority) + (additional :initform (make-array 1 :adjustable t :fill-pointer 0) + :initarg :additional :accessor dns-message-additional))) + +(defmacro define-flags-bitfield (name offset length &optional (type :integer)) + (let ((method-name (et::symbolicate name :-field))) + `(progn + (defmethod ,method-name ((message dns-message)) + ,(ecase type + (:integer `(ldb (byte ,length ,offset) (dns-message-flags message))) + (:boolean `(logbitp ,offset (dns-message-flags message))) + (:rcode `(rcode-id + (ldb (byte ,length ,offset) (dns-message-flags message)))))) + (defmethod (setf ,method-name) (value (message dns-message)) + ,(ecase type + (:integer `(setf (ldb (byte ,length ,offset) (dns-message-flags message)) + value)) + (:boolean `(setf (ldb (byte ,length ,offset) (dns-message-flags message)) + (lisp->c-bool value))) + (:rcode `(setf (ldb (byte ,length ,offset) (dns-message-flags message)) + (rcode-number value)))))))) + +(define-flags-bitfield response 15 1 :boolean) +(define-flags-bitfield opcode 11 4 :integer) +(define-flags-bitfield authoritative 10 1 :boolean) +(define-flags-bitfield truncated 9 1 :boolean) +(define-flags-bitfield recursion-desired 8 1 :boolean) +(define-flags-bitfield recursion-available 7 1 :boolean) +(define-flags-bitfield rcode 0 4 :rcode) + +(defclass dns-record () + ((name :initarg :name :accessor dns-record-name) + (type :initarg :type :accessor dns-record-type) + (class :initarg :class :accessor dns-record-class))) + +(defmethod initialize-instance :after ((record dns-record) &key) + (with-slots (name type class) record + (check-type name string "a string") + (check-type type (satisfies valid-type-p) "a valid record type") + (check-type class (member :in) "a valid record class"))) + +(defclass dns-question (dns-record) ()) + +(defmethod initialize-instance :after ((record dns-record) &key) + (with-slots (name) record + (let ((name-length (length name))) + (when (char-not-equal (aref name (1- name-length)) + #\.) + (setf name (concatenate 'string name (string #\.))))))) + +(defclass dns-rr (dns-record) + ((ttl :initarg :ttl :accessor dns-rr-ttl))) + +(defmethod initialize-instance :after ((rr dns-rr) &key) + (with-slots (ttl) rr + (check-type ttl (unsigned-byte 32) "a valid TTL"))) + +(defclass dns-rr-a (dns-rr) + ((address :initarg :address :accessor dns-rr-a-address)) + (:default-initargs :type :a)) + +(defclass dns-rr-ns (dns-rr) + ((dname :initarg :dname :accessor dns-rr-ns-dname)) + (:default-initargs :type :ns)) + +(defclass dns-rr-cname (dns-rr) () + (:default-initargs :type :cname)) + +(defclass dns-rr-soa (dns-rr) + ((mname :initarg :mname :accessor dns-rr-soa-mname) + (rname :initarg :rname :accessor dns-rr-soa-rname) + (serial :initarg :serial :accessor dns-rr-soa-serial) + (refresh :initarg :refresh :accessor dns-rr-soa-refresh) + (retry :initarg :retry :accessor dns-rr-soa-retry) + (expire :initarg :expire :accessor dns-rr-soa-expire) + (minimum :initarg :minimum :accessor dns-rr-soa-minimum)) + (:default-initargs :type :soa)) + +(defclass dns-rr-wks (dns-rr) + ((address :initarg :address :accessor dns-rr-wks-address) + (protocol :initarg :protocol :accessor dns-rr-wks-protocol) + (bitmap :initarg :bitmap :accessor dns-rr-wkx-bitmap)) + (:default-initargs :type :wks)) + +(defclass dns-rr-ptr (dns-rr) + ((dname :initarg :dname :accessor dns-rr-ptr-dname)) + (:default-initargs :type :ptr)) + +(defclass dns-rr-hinfo (dns-rr) + ((cpu :initarg :cpu :accessor dns-rr-hinfo-cpu) + (os :initarg :os :accessor dns-rr-hinfo-os)) + (:default-initargs :type :hinfo)) + +(defclass dns-rr-mx (dns-rr) + ((preference :initarg :preference :accessor dns-rr-mx-preference) + (exchange :initarg :exchange :accessor dns-rr-mx-exchange)) + (:default-initargs :type :mx)) + +(defclass dns-rr-txt (dns-rr) + ((data :initarg :data :accessor dns-rr-txt-data)) + (:default-initargs :type :txt)) + +(defclass dns-rr-aaaa (dns-rr) + ((address :initarg :address :accessor dns-rr-aaaa-address)) + (:default-initargs :type :aaaa)) + +(defmethod add-answer-rr ((message dns-message) + (record dns-rr)) + (vector-push-extend record (dns-message-answer message))) + +(defmethod add-authority-rr ((message dns-message) + (record dns-rr)) + (vector-push-extend record (dns-message-authority message))) + +(defmethod add-additional-rr ((message dns-message) + (record dns-rr)) + (vector-push-extend record (dns-message-additional message))) + + +;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; CONSTRUCTORS ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;; + +(defun make-question (qname qtype qclass) + (make-instance 'dns-question + :name qname + :type qtype + :class qclass)) + +(defun make-query (id question + &optional (recursion-desired *dns-recursion-desired*)) + (let ((msg (make-instance 'dns-message :id id))) + (setf (opcode-field msg) +opcode-standard+) + (setf (recursion-desired-field msg) recursion-desired) + (setf (dns-message-question msg) question) + msg)) + + +;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; OUTPUT-RECORD ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod output-record ((buffer dynamic-buffer) + (record dns-question)) + (with-slots (name type class) record + (output-domain-name buffer name) + (output-unsigned-16 buffer (query-type-number type)) + (output-unsigned-16 buffer (query-class-number class)))) + +(defmethod output-message-header ((buffer dynamic-buffer) + (message dns-message)) + (with-slots (id flags question answer authority additional) + message + (output-unsigned-16 buffer id) + (output-unsigned-16 buffer flags) + (output-unsigned-16 buffer 1) + (output-unsigned-16 buffer (length answer)) + (output-unsigned-16 buffer (length authority)) + (output-unsigned-16 buffer (length additional)))) + +(defmethod output-message ((message dns-message)) + (with-slots (question) message + (let ((buffer (make-instance 'dynamic-buffer))) + (output-message-header buffer message) + (output-record buffer question) + buffer))) diff --git a/protocols/dns-client/dns-response.lisp b/protocols/dns-client/dns-response.lisp new file mode 100644 index 0000000..fed1302 --- /dev/null +++ b/protocols/dns-client/dns-response.lisp @@ -0,0 +1,26 @@ +;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Copyright (C) 2006 by Stelian Ionescu ; +; ; +; This program is free software; you can redistribute it and/or modify ; +; it under the terms of the GNU General Public License as published by ; +; the Free Software Foundation; either version 2 of the License, or ; +; (at your option) any later version. ; +; ; +; This program is distributed in the hope that it will be useful, ; +; but WITHOUT ANY WARRANTY; without even the implied warranty of ; +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; +; GNU General Public License for more details. ; +; ; +; You should have received a copy of the GNU General Public License ; +; along with this program; if not, write to the ; +; Free Software Foundation, Inc., ; +; 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2))) +(declaim (optimize (speed 0) (safety 2) (space 0) (debug 2))) + +(in-package #:net.sockets) + diff --git a/protocols/dns-client/dynamic-buffer.lisp b/protocols/dns-client/dynamic-buffer.lisp new file mode 100644 index 0000000..6c6e63f --- /dev/null +++ b/protocols/dns-client/dynamic-buffer.lisp @@ -0,0 +1,100 @@ +;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Copyright (C) 2006 by Stelian Ionescu ; +; ; +; This program is free software; you can redistribute it and/or modify ; +; it under the terms of the GNU General Public License as published by ; +; the Free Software Foundation; either version 2 of the License, or ; +; (at your option) any later version. ; +; ; +; This program is distributed in the hope that it will be useful, ; +; but WITHOUT ANY WARRANTY; without even the implied warranty of ; +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; +; GNU General Public License for more details. ; +; ; +; You should have received a copy of the GNU General Public License ; +; along with this program; if not, write to the ; +; Free Software Foundation, Inc., ; +; 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2))) +(declaim (optimize (speed 0) (safety 2) (space 0) (debug 3))) + +(in-package #:net.sockets) + +(defclass dynamic-buffer () + ((contents :reader buffer-contents) + (length :initform 0 :reader buffer-length) + (size :initarg :size :reader buffer-size)) + (:default-initargs :size +dns-datagram-size+)) + +(defmethod initialize-instance :after ((buffer dynamic-buffer) + &key size) + (setf (slot-value buffer 'contents) + (make-array size :element-type '(unsigned-byte 8) + :adjustable t :fill-pointer 0))) + +(defun ub16-to-vector (value) + (vector (ldb (byte 8 8) value) + (ldb (byte 8 0) value))) + +(defun ub32-to-vector (value) + (vector (ldb (byte 8 32) value) + (ldb (byte 8 16) value) + (ldb (byte 8 8) value) + (ldb (byte 8 0) value))) + +(defmethod output-vector :before ((buffer dynamic-buffer) + vector) + (with-slots (contents length size) buffer + (let ((vector-length (length vector))) + (when (< size (+ length vector-length)) + (let ((newsize (+ size vector-length 50))) + (setf contents (adjust-array contents newsize)) + (setf size newsize)))))) + +(defmethod output-vector ((buffer dynamic-buffer) + vector) + (with-slots (contents length) buffer + (let ((vector-length (length vector))) + (incf (fill-pointer contents) vector-length) + (replace contents vector :start1 length) + (incf length vector-length))) + buffer) + +(defmethod output-unsigned-8 ((buffer dynamic-buffer) + (value integer)) + (output-vector buffer (vector value))) + +(defmethod output-unsigned-16 ((buffer dynamic-buffer) + (value integer)) + (output-vector buffer (ub16-to-vector value))) + +(defmethod output-unsigned-32 ((buffer dynamic-buffer) + (value integer)) + (output-vector buffer (ub32-to-vector value))) + +(defmethod output-string ((buffer dynamic-buffer) + (string simple-string)) + (output-unsigned-8 buffer (length string)) + (output-vector buffer (sb-ext:string-to-octets string))) + +(defun domain-name-to-dns-format (domain-name) + (let* ((octets (sb-ext:string-to-octets domain-name)) + (tmp-vec (make-array (1+ (length octets)) + :element-type '(unsigned-byte 8)))) + (replace tmp-vec octets :start1 1) + (let ((vector-length (length tmp-vec))) + (loop + :for start-off := 1 then (1+ end-off) + :for end-off := (or (position (char-code #\.) tmp-vec :start start-off) + vector-length) + :do (setf (aref tmp-vec (1- start-off)) (- end-off start-off)) + :when (>= end-off vector-length) :do (loop-finish))) + tmp-vec)) + +(defmethod output-domain-name ((buffer dynamic-buffer) + (domain-name simple-string)) + (output-vector buffer (domain-name-to-dns-format domain-name))) diff --git a/protocols/dns-client/export.lisp b/protocols/dns-client/export.lisp new file mode 100644 index 0000000..fed1302 --- /dev/null +++ b/protocols/dns-client/export.lisp @@ -0,0 +1,26 @@ +;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Copyright (C) 2006 by Stelian Ionescu ; +; ; +; This program is free software; you can redistribute it and/or modify ; +; it under the terms of the GNU General Public License as published by ; +; the Free Software Foundation; either version 2 of the License, or ; +; (at your option) any later version. ; +; ; +; This program is distributed in the hope that it will be useful, ; +; but WITHOUT ANY WARRANTY; without even the implied warranty of ; +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ; +; GNU General Public License for more details. ; +; ; +; You should have received a copy of the GNU General Public License ; +; along with this program; if not, write to the ; +; Free Software Foundation, Inc., ; +; 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA ; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (declaim (optimize (speed 2) (safety 2) (space 1) (debug 2))) +(declaim (optimize (speed 0) (safety 2) (space 0) (debug 2))) + +(in-package #:net.sockets) + diff --git a/protocols/dns-client/net.dns-client.asd b/protocols/dns-client/net.dns-client.asd new file mode 100644 index 0000000..299f901 --- /dev/null +++ b/protocols/dns-client/net.dns-client.asd @@ -0,0 +1,21 @@ +;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- + +(in-package #:cl-user) + +(defpackage #:net.dns-client.system + (:use #:common-lisp #:asdf)) + +(in-package #:net.dns-client.system) + +(defsystem net.dns-client + :description "DNS client library." + :author "Stelian Ionescu " + :maintainer "Stelian Ionescu " + :licence "GPL-2.1" + :depends-on (#:net.sockets) + :components + ((:file "export") + (:file "dns-constants") + (:file "dynamic-buffer" :depends-on ("dns-constants")) + (:file "dns-query" :depends-on ("dns-constants" "dynamic-buffer")) + (:file "dns-response" :depends-on ("dns-constants" "dns-query")))) -- 2.11.4.GIT