protocols/dns-client/dns-query.lisp

   1 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;   Copyright (C) 2006 by Stelian Ionescu                                 ;
   5 ;                                                                         ;
   6 ;   This program is free software; you can redistribute it and/or modify  ;
   7 ;   it under the terms of the GNU General Public License as published by  ;
   8 ;   the Free Software Foundation; either version 2 of the License, or     ;
   9 ;   (at your option) any later version.                                   ;
  10 ;                                                                         ;
  11 ;   This program is distributed in the hope that it will be useful,       ;
  12 ;   but WITHOUT ANY WARRANTY; without even the implied warranty of        ;
  13 ;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         ;
  14 ;   GNU General Public License for more details.                          ;
  15 ;                                                                         ;
  16 ;   You should have received a copy of the GNU General Public License     ;
  17 ;   along with this program; if not, write to the                         ;
  18 ;   Free Software Foundation, Inc.,                                       ;
  19 ;   51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA              ;
  20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  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 ancount nscount arcount)
  88   (with-slots (id flags decoded-flags question answer authority additional) msg
  89     (setf decoded-flags (decode-flags msg))
  90     (setf question (make-array qdcount :adjustable t :fill-pointer 0))
  91     (setf answer (make-array ancount :adjustable t :fill-pointer 0))
  92     (setf authority (make-array nscount :adjustable t :fill-pointer 0))
  93     (setf additional (make-array arcount :adjustable t :fill-pointer 0))))
  94
  95 (defclass dns-record ()
  96   ((name  :initarg :name  :accessor dns-record-name)
  97    (type  :initarg :type  :accessor dns-record-type)
  98    (class :initarg :class :accessor dns-record-class)))
  99
 100 (defmethod initialize-instance :after ((record dns-record) &key)
 101   (with-slots (name type class) record
 102     (check-type name string "a string")
 103     (check-type type (satisfies valid-type-p) "a valid record type")
 104     (check-type class (member :in) "a valid record class")))
 105
 106 (defclass dns-question (dns-record) ())
 107
 108 (defmethod initialize-instance :after ((record dns-question) &key)
 109   (with-slots (name) record
 110     (let ((name-length (length name)))
 111       (when (char-not-equal (aref name (1- name-length))
 112                             #\.)
 113         (setf name (concatenate 'string name (string #\.)))))))
 114
 115
 116 ;;;;;;;;;;;;;;;;;;;;;;
 117 ;;;                ;;;
 118 ;;;  CONSTRUCTORS  ;;;
 119 ;;;                ;;;
 120 ;;;;;;;;;;;;;;;;;;;;;;
 121
 122 (defun make-question (qname qtype qclass)
 123   (make-instance 'dns-question
 124                  :name qname
 125                  :type qtype
 126                  :class qclass))
 127
 128 (defun make-query (id question &optional recursion-desired)
 129   (let ((msg (make-instance 'dns-message :id id)))
 130     (setf (opcode-field msg) +opcode-standard+)
 131     (setf (recursion-desired-field msg) recursion-desired)
 132     (vector-push-extend question (dns-message-question msg))
 133     msg))
 134
 135
 136 ;;;;;;;;;;;;;;;;;;;;;;;
 137 ;;;                 ;;;
 138 ;;;  OUTPUT-RECORD  ;;;
 139 ;;;                 ;;;
 140 ;;;;;;;;;;;;;;;;;;;;;;;
 141
 142 (defgeneric write-dns-string (buffer string))
 143 (defmethod write-dns-string ((buffer dynamic-output-buffer)
 144                              (string string))
 145   (write-unsigned-8 buffer (length string))
 146   (write-vector buffer (flexi-streams:string-to-octets string)))
 147
 148 (defun domain-name-to-dns-format (domain-name)
 149   (let* ((octets (flexi-streams:string-to-octets domain-name))
 150          (tmp-vec (make-array (1+ (length octets))
 151                               :element-type 'octet)))
 152     (replace tmp-vec octets :start1 1)
 153     (let ((vector-length (length tmp-vec)))
 154       (loop
 155          :for start-off := 1 then (1+ end-off)
 156          :for end-off := (or (position (char-code #\.) tmp-vec :start start-off)
 157                              vector-length)
 158          :do (setf (aref tmp-vec (1- start-off)) (- end-off start-off))
 159          :when (>= end-off vector-length) :do (loop-finish)))
 160     tmp-vec))
 161
 162 (defgeneric write-domain-name (buffer name))
 163 (defmethod write-domain-name ((buffer dynamic-output-buffer)
 164                               (domain-name string))
 165   (write-vector buffer (domain-name-to-dns-format domain-name)))
 166
 167 (defgeneric write-record (buffer record))
 168 (defmethod write-record ((buffer dynamic-output-buffer)
 169                          (record dns-question))
 170   (with-slots (name type class) record
 171     (write-domain-name buffer name)
 172     (write-unsigned-16 buffer (query-type-number type))
 173     (write-unsigned-16 buffer (query-class-number class))))
 174
 175 (defgeneric write-message-header (buffer message))
 176 (defmethod write-message-header ((buffer dynamic-output-buffer)
 177                                  (message dns-message))
 178   (with-slots (id flags question answer authority additional)
 179       message
 180     (write-unsigned-16 buffer id)
 181     (write-unsigned-16 buffer flags)
 182     (write-unsigned-16 buffer (length question))
 183     (write-unsigned-16 buffer (length answer))
 184     (write-unsigned-16 buffer (length authority))
 185     (write-unsigned-16 buffer (length additional))))
 186
 187 (defgeneric write-dns-message (message))
 188 (defmethod write-dns-message ((message dns-message))
 189   (with-slots (question) message
 190     (with-output-buffer buffer
 191       (write-message-header buffer message)
 192       (write-record buffer (aref question 0)))))