protocols/dns-client/dynamic-buffer.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 (deftype octet ()
  25   `(unsigned-byte 8))
  26
  27 (defclass dynamic-output-buffer ()
  28   ((sequence :initform nil    :reader buffer-sequence)
  29    (length   :initform 0      :reader buffer-length)
  30    (size     :initarg :size   :reader buffer-size))
  31   (:default-initargs :size +dns-datagram-size+))
  32
  33 (defmethod initialize-instance :after ((buffer dynamic-output-buffer)
  34                                        &key (size 50))
  35   (setf (slot-value buffer 'sequence)
  36         (make-array size :element-type 'octet
  37                     :adjustable t :fill-pointer 0)))
  38
  39 (defun ub16-to-vector (value)
  40   (vector (ldb (byte 8 8) value)
  41           (ldb (byte 8 0) value)))
  42
  43 (defun ub32-to-vector (value)
  44   (vector (ldb (byte 8 32) value)
  45           (ldb (byte 8 16) value)
  46           (ldb (byte 8 8) value)
  47           (ldb (byte 8 0) value)))
  48
  49 (defgeneric write-vector (buffer vector))
  50
  51 (defmethod write-vector :before ((buffer dynamic-output-buffer)
  52                                  (vector array))
  53   (with-slots (sequence length size) buffer
  54     (let ((vector-length (length vector)))
  55       (when (< size (+ length vector-length))
  56         (let ((newsize (+ size vector-length 50)))
  57           (setf sequence (adjust-array sequence newsize))
  58           (setf size newsize))))))
  59
  60 (defmethod write-vector ((buffer dynamic-output-buffer)
  61                          (vector array))
  62   (with-slots (sequence length) buffer
  63     (let ((vector-length (length vector)))
  64       (incf (fill-pointer sequence) vector-length)
  65       (replace sequence vector :start1 length)
  66       (incf length vector-length)))
  67   buffer)
  68
  69 (defgeneric write-unsigned-8 (buffer vector))
  70 (defmethod write-unsigned-8 ((buffer dynamic-output-buffer)
  71                              (value integer))
  72   (write-vector buffer (vector value)))
  73
  74 (defgeneric write-unsigned-16 (buffer vector))
  75 (defmethod write-unsigned-16 ((buffer dynamic-output-buffer)
  76                               (value integer))
  77   (write-vector buffer (ub16-to-vector value)))
  78
  79 (defgeneric write-unsigned-32 (buffer vector))
  80 (defmethod write-unsigned-32 ((buffer dynamic-output-buffer)
  81                               (value integer))
  82   (write-vector buffer (ub32-to-vector value)))
  83
  84 (defmacro with-output-buffer (var &body body)
  85   `(let ((,var (make-instance 'dynamic-output-buffer)))
  86      ,@body
  87      ,var))
  88
  89
  90 (defclass dynamic-input-buffer ()
  91   ((sequence :initform nil :initarg :sequence :reader buffer-sequence)
  92    (position :initform 0   :reader buffer-position)
  93    (size     :reader buffer-size)))
  94
  95 (defmethod initialize-instance :after ((buffer dynamic-input-buffer) &key size)
  96   (with-slots (sequence (seq-size size)) buffer
  97     (setf seq-size (or size (length sequence)))
  98     (cond
  99       ((null sequence)
 100        (setf sequence (make-array 0 :element-type 'octet :adjustable t
 101                                   :initial-contents sequence)))
 102       ((not (and (adjustable-array-p sequence)
 103                  (typep sequence '(vector octet))))
 104        (setf sequence (make-array seq-size
 105                                   :element-type 'octet :adjustable t
 106                                   :displaced-to sequence))))))
 107
 108 (define-condition input-buffer-error (error) ())
 109
 110 (define-condition input-buffer-scarcity (input-buffer-error)
 111   ((bytes-requested :initarg :requested :reader bytes-requested)
 112    (bytes-remaining :initarg :remaining :reader bytes-remaining))
 113   (:documentation "Signals that an INPUT-BUFFER contains less unread bytes than requested."))
 114
 115 (define-condition input-buffer-eof (input-buffer-scarcity) ()
 116   (:documentation "Signals that an INPUT-BUFFER contains no more unread bytes."))
 117
 118 (define-condition input-buffer-index-out-of-bounds (input-buffer-error) ()
 119   (:documentation "Signals that BUFFER-SEEK on an INPUT-BUFFER was passed an invalid offset."))
 120
 121 (defgeneric buffer-seek (buffer offset))
 122 (defmethod buffer-seek ((buffer dynamic-input-buffer) offset)
 123   (check-type offset unsigned-byte "a non-negative value")
 124   (with-slots (sequence size position) buffer
 125     (if (> offset (1- size))
 126         (error 'input-buffer-index-out-of-bounds)
 127         (setf position offset))))
 128
 129 (defgeneric buffer-append (buffer vector))
 130 (defmethod buffer-append ((buffer dynamic-input-buffer)
 131                           vector)
 132   (with-slots (sequence size) buffer
 133     (when (plusp (length vector))
 134       (let ((oldsize size)
 135             (newsize (+ (length sequence)
 136                         (length vector))))
 137         (setf sequence (adjust-array sequence newsize))
 138         (replace sequence vector :start1 oldsize)
 139         (setf size newsize)))))
 140
 141 (defgeneric bytes-unread (buffer))
 142 (defmethod bytes-unread ((buffer dynamic-input-buffer))
 143   (with-slots (position size) buffer
 144     (- size position)))
 145
 146 (defgeneric check-if-enough-bytes (buffer length &key check-all))
 147 (defmethod check-if-enough-bytes ((buffer dynamic-input-buffer)
 148                                   length &key (check-all t))
 149   (let ((bytes-unread (bytes-unread buffer)))
 150     (cond
 151       ((and (zerop bytes-unread)
 152             (plusp length))
 153        (error 'input-buffer-eof
 154               :requested length
 155               :remaining bytes-unread))
 156       ((and check-all
 157             (< bytes-unread length))
 158        (error 'input-buffer-scarcity
 159               :requested length
 160               :remaining bytes-unread)))
 161     t))
 162
 163 (defun read-ub16-from-vector (vector position)
 164   (+ (ash (aref vector position) 8)
 165      (aref vector (1+ position))))
 166
 167 (defun read-ub32-from-vector (vector position)
 168   (+ (ash (aref vector position) 24)
 169      (ash (aref vector (1+ position)) 16)
 170      (ash (aref vector (+ position 2)) 8)
 171      (aref vector (+ position 3))))
 172
 173 (defgeneric read-vector (buffer length &key read-all))
 174 (defmethod read-vector ((buffer dynamic-input-buffer)
 175                         length &key (read-all t))
 176   (let* ((bytes-to-read
 177           (min (bytes-unread buffer) length))
 178          (newvector
 179           (make-array bytes-to-read :element-type 'octet)))
 180     (check-if-enough-bytes buffer length :check-all read-all)
 181     (with-slots (sequence position) buffer
 182       (replace newvector sequence :start2 position)
 183       (incf position bytes-to-read))
 184     newvector))
 185
 186 (defgeneric read-unsigned-8 (buffer))
 187 (defmethod read-unsigned-8 ((buffer dynamic-input-buffer))
 188   (check-if-enough-bytes buffer 1)
 189   (with-slots (sequence position) buffer
 190     (prog1
 191         (aref sequence position)
 192       (incf position))))
 193
 194 (defgeneric read-unsigned-16 (buffer))
 195 (defmethod read-unsigned-16 ((buffer dynamic-input-buffer))
 196   (check-if-enough-bytes buffer 2)
 197   (with-slots (sequence position) buffer
 198     (prog1
 199         (read-ub16-from-vector sequence position)
 200       (incf position 2))))
 201
 202 (defgeneric read-unsigned-32 (buffer))
 203 (defmethod read-unsigned-32 ((buffer dynamic-input-buffer))
 204   (check-if-enough-bytes buffer 4)
 205   (with-slots (sequence position) buffer
 206     (prog1
 207         (read-ub32-from-vector sequence position)
 208       (incf position 4))))
 209
 210 (defmacro with-input-buffer ((var) &body body)
 211   `(let ((,var (make-instance 'dynamic-input-buffer)))
 212      ,@body
 213      ,var))