protocols/dns-client/dns-query.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;   Copyright (C) 2006, 2007 Stelian Ionescu
   4 ;;
   5 ;;   This code is free software; you can redistribute it and/or
   6 ;;   modify it under the terms of the version 2.1 of
   7 ;;   the GNU Lesser General Public License as published by
   8 ;;   the Free Software Foundation, as clarified by the
   9 ;;   preamble found here:
  10 ;;       http://opensource.franz.com/preamble.html
  11 ;;
  12 ;;   This program is distributed in the hope that it will be useful,
  13 ;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;   GNU General Public License for more details.
  16 ;;
  17 ;;   You should have received a copy of the GNU Lesser General
  18 ;;   Public License along with this library; if not, write to the
  19 ;;   Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  20 ;;   Boston, MA 02110-1301, USA
  21
  22 (in-package :net.sockets)
  23
  24 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25 ;;;                     ;;;
  26 ;;;  CLASS DEFINITIONS  ;;;
  27 ;;;                     ;;;
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29
  30 (defclass dns-message ()
  31   ((id    :initform 0 :initarg :id    :accessor dns-message-id)
  32    (flags :initform 0 :initarg :flags :accessor dns-message-flags)
  33    (decoded-flags :reader decoded-flags)
  34    (qdcount :initarg :qdcount :reader dns-message-question-count)
  35    (ancount :initarg :ancount :reader dns-message-answer-count)
  36    (nscount :initarg :nscount :reader dns-message-authority-count)
  37    (arcount :initarg :arcount :reader dns-message-additional-count)
  38    (question   :reader dns-message-question)
  39    (answer     :reader dns-message-answer)
  40    (authority  :reader dns-message-authority)
  41    (additional :reader dns-message-additional))
  42   (:default-initargs :qdcount 1 :ancount 0 :nscount 0 :arcount 0))
  43
  44 (defmacro define-flags-bitfield (name offset length &optional (type :integer))
  45   (let ((method-name (iolib-utils:concat-symbol name :-field)))
  46     `(progn
  47        (defgeneric ,method-name (message))
  48        (defmethod ,method-name ((message dns-message))
  49          ,(ecase type
  50            (:integer `(ldb (byte ,length ,offset) (dns-message-flags message)))
  51            (:boolean `(logbitp ,offset (dns-message-flags message)))
  52            (:rcode `(rcode-id
  53                      (ldb (byte ,length ,offset) (dns-message-flags message))))))
  54        (defgeneric (setf ,method-name) (value message))
  55        (defmethod (setf ,method-name) (value (message dns-message))
  56          ,(ecase type
  57            (:integer `(setf (ldb (byte ,length ,offset) (dns-message-flags message))
  58                             value))
  59            (:boolean `(setf (ldb (byte ,length ,offset) (dns-message-flags message))
  60                             (lisp->c-bool value)))
  61            (:rcode `(setf (ldb (byte ,length ,offset) (dns-message-flags message))
  62                           (rcode-number value))))))))
  63
  64 (define-flags-bitfield response 15 1 :boolean)
  65 (define-flags-bitfield opcode 11 4 :integer)
  66 (define-flags-bitfield authoritative 10 1 :boolean)
  67 (define-flags-bitfield truncated 9 1 :boolean)
  68 (define-flags-bitfield recursion-desired 8 1 :boolean)
  69 (define-flags-bitfield recursion-available 7 1 :boolean)
  70 (define-flags-bitfield rcode 0 4 :rcode)
  71
  72 (defgeneric decode-flags (message))
  73 (defmethod decode-flags ((msg dns-message))
  74   (let (flags)
  75     (push (if (response-field msg) :response :query) flags)
  76     (push (if (eql (opcode-field msg) +opcode-standard+)
  77               :opcode-standard :opcode-unknown)
  78           flags)
  79     (when (authoritative-field msg) (push :authoritative flags))
  80     (when (truncated-field msg) (push :truncated flags))
  81     (when (recursion-desired-field msg) (push :recursion-desired flags))
  82     (when (recursion-available-field msg) (push :recursion-available flags))
  83     (push (or (rcode-field msg) :rcode-unknown) flags)
  84     (nreverse flags)))
  85
  86 (defmethod initialize-instance :after ((msg dns-message) &key
  87                                        (qdcount 0) (ancount 0)
  88                                        (nscount 0) (arcount 0))
  89   (with-slots (id flags decoded-flags question answer authority additional) msg
  90     (setf decoded-flags (decode-flags msg))
  91     (setf question (make-array qdcount :adjustable t :fill-pointer 0))
  92     (setf answer (make-array ancount :adjustable t :fill-pointer 0))
  93     (setf authority (make-array nscount :adjustable t :fill-pointer 0))
  94     (setf additional (make-array arcount :adjustable t :fill-pointer 0))))
  95
  96 (defclass dns-record ()
  97   ((name  :initarg :name  :accessor dns-record-name)
  98    (type  :initarg :type  :accessor dns-record-type)
  99    (class :initarg :class :accessor dns-record-class)))
 100
 101 (defmethod initialize-instance :after ((record dns-record) &key)
 102   (with-slots (name type class) record
 103     (check-type name string "a string")
 104     (check-type type (satisfies valid-type-p) "a valid record type")
 105     (check-type class (member :in) "a valid record class")))
 106
 107 (defclass dns-question (dns-record) ())
 108
 109 (defmethod initialize-instance :after ((record dns-question) &key)
 110   (with-slots (name) record
 111     (let ((name-length (length name)))
 112       (when (char-not-equal (aref name (1- name-length))
 113                             #\.)
 114         (setf name (concatenate 'string name (string #\.)))))))
 115
 116
 117 ;;;;;;;;;;;;;;;;;;;;;;
 118 ;;;                ;;;
 119 ;;;  CONSTRUCTORS  ;;;
 120 ;;;                ;;;
 121 ;;;;;;;;;;;;;;;;;;;;;;
 122
 123 (defun make-question (qname qtype qclass)
 124   (make-instance 'dns-question
 125                  :name qname
 126                  :type qtype
 127                  :class qclass))
 128
 129 (defun make-query (id question &optional recursion-desired)
 130   (let ((msg (make-instance 'dns-message :id id)))
 131     (setf (opcode-field msg) +opcode-standard+)
 132     (setf (recursion-desired-field msg) recursion-desired)
 133     (vector-push-extend question (dns-message-question msg))
 134     msg))
 135
 136
 137 ;;;;;;;;;;;;;;;;;;;;;;;
 138 ;;;                 ;;;
 139 ;;;  OUTPUT-RECORD  ;;;
 140 ;;;                 ;;;
 141 ;;;;;;;;;;;;;;;;;;;;;;;
 142
 143 (defgeneric write-dns-string (buffer string))
 144 (defmethod write-dns-string ((buffer dynamic-output-buffer)
 145                              (string string))
 146   (write-unsigned-8 buffer (length string))
 147   (write-vector buffer (flexi-streams:string-to-octets string)))
 148
 149 (defun domain-name-to-dns-format (domain-name)
 150   (let* ((octets (flexi-streams:string-to-octets domain-name))
 151          (tmp-vec (make-array (1+ (length octets))
 152                               :element-type 'octet)))
 153     (replace tmp-vec octets :start1 1)
 154     (let ((vector-length (length tmp-vec)))
 155       (loop
 156          :for start-off := 1 then (1+ end-off)
 157          :for end-off := (or (position (char-code #\.) tmp-vec :start start-off)
 158                              vector-length)
 159          :do (setf (aref tmp-vec (1- start-off)) (- end-off start-off))
 160          :when (>= end-off vector-length) :do (loop-finish)))
 161     tmp-vec))
 162
 163 (defgeneric write-domain-name (buffer name))
 164 (defmethod write-domain-name ((buffer dynamic-output-buffer)
 165                               (domain-name string))
 166   (write-vector buffer (domain-name-to-dns-format domain-name)))
 167
 168 (defgeneric write-record (buffer record))
 169 (defmethod write-record ((buffer dynamic-output-buffer)
 170                          (record dns-question))
 171   (with-slots (name type class) record
 172     (write-domain-name buffer name)
 173     (write-unsigned-16 buffer (query-type-number type))
 174     (write-unsigned-16 buffer (query-class-number class))))
 175
 176 (defgeneric write-message-header (buffer message))
 177 (defmethod write-message-header ((buffer dynamic-output-buffer)
 178                                  (message dns-message))
 179   (with-slots (id flags question answer authority additional)
 180       message
 181     (write-unsigned-16 buffer id)
 182     (write-unsigned-16 buffer flags)
 183     (write-unsigned-16 buffer (length question))
 184     (write-unsigned-16 buffer (length answer))
 185     (write-unsigned-16 buffer (length authority))
 186     (write-unsigned-16 buffer (length additional))))
 187
 188 (defgeneric write-dns-message (message))
 189 (defmethod write-dns-message ((message dns-message))
 190   (with-slots (question) message
 191     (with-output-buffer buffer
 192       (write-message-header buffer message)
 193       (write-record buffer (aref question 0)))))