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