net.sockets/dns/dynamic-buffer.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Read/write adjustable buffer.
   4 ;;;
   5
   6 (in-package :net.sockets)
   7
   8 (defclass dynamic-buffer ()
   9   ((sequence     :initform nil  :accessor sequence-of)
  10    (read-cursor  :initform 0    :accessor read-cursor-of)
  11    (write-cursor :initform 0    :accessor write-cursor-of)))
  12
  13 (defmethod initialize-instance :after ((buffer dynamic-buffer)
  14                                        &key (size 256) sequence (start 0) end)
  15   (etypecase sequence
  16     (null
  17      (setf (sequence-of buffer) (make-array size :element-type 'ub8)))
  18     (ub8-vector
  19      (check-bounds sequence start end)
  20      (let* ((sequence-size (- end start))
  21             (newseq (make-array sequence-size :element-type 'ub8)))
  22        (replace newseq sequence :start2 start :end2 end)
  23        (setf (sequence-of buffer)     newseq
  24              (write-cursor-of buffer) sequence-size)))))
  25
  26 (defmethod print-object ((buffer dynamic-buffer) stream)
  27   (print-unreadable-object (buffer stream :type t :identity t)
  28     (let ((*print-length* 40))
  29       (format stream "Size: ~A RC: ~A WC: ~A Contents: ~S"
  30               (size-of buffer)
  31               (read-cursor-of buffer)
  32               (write-cursor-of buffer)
  33               (sequence-of buffer)))))
  34
  35 (defmethod size-of ((buffer dynamic-buffer))
  36   (length (sequence-of buffer)))
  37
  38 (declaim (inline ub16-to-vector))
  39 (defun ub16-to-vector (value)
  40   (vector (ldb (byte 8 8) value)
  41           (ldb (byte 8 0) value)))
  42
  43 (declaim (inline ub32-to-vector))
  44 (defun ub32-to-vector (value)
  45   (vector (ldb (byte 8 32) value)
  46           (ldb (byte 8 16) value)
  47           (ldb (byte 8 8) value)
  48           (ldb (byte 8 0) value)))
  49
  50 (defun maybe-grow-buffer (buffer vector)
  51   (with-accessors ((seq sequence-of)
  52                    (size size-of)
  53                    (wcursor write-cursor-of))
  54       buffer
  55     (let ((vlen (length vector)))
  56       (when (< size (+ wcursor vlen))
  57         (let ((newsize (* 3/2 (+ size vlen))))
  58           (setf seq (adjust-array seq newsize))))))
  59   (values buffer))
  60
  61 (defun write-vector (buffer vector)
  62   (maybe-grow-buffer buffer vector)
  63   (with-accessors ((seq sequence-of)
  64                    (wcursor write-cursor-of))
  65       buffer
  66     (let ((vlen (length vector)))
  67       (replace seq vector :start1 wcursor)
  68       (incf wcursor vlen)))
  69   (values buffer))
  70
  71 (declaim (inline write-ub8))
  72 (defun write-ub8 (buffer value)
  73   (write-vector buffer (vector value)))
  74
  75 (declaim (inline write-ub16))
  76 (defun write-ub16 (buffer value)
  77   (write-vector buffer (ub16-to-vector value)))
  78
  79 (declaim (inline write-ub32))
  80 (defun write-ub32 (buffer value)
  81   (write-vector buffer (ub32-to-vector value)))
  82
  83 (define-condition dynamic-buffer-input-error (error)
  84   ((buffer :initform (error "Must supply buffer")
  85            :initarg :buffer :reader buffer-of)))
  86
  87 (define-condition input-buffer-eof (dynamic-buffer-input-error)
  88   ((octets-requested :initarg :requested :reader octets-requested)
  89    (octets-remaining :initarg :remaining :reader octets-remaining))
  90   (:report (lambda (condition stream)
  91              (format stream "You requested ~a octets but only ~A are left in the buffer"
  92                      (octets-requested condition)
  93                      (octets-remaining condition))))
  94   (:documentation
  95    "Signals that an INPUT-BUFFER contains less unread bytes than requested."))
  96
  97 (define-condition input-buffer-index-out-of-bounds (dynamic-buffer-input-error) ()
  98   (:documentation
  99    "Signals that DYNAMIC-BUFFER-SEEK-READ-CURSOR on an INPUT-BUFFER was passed an
 100 invalid offset."))
 101
 102 (defun seek-read-cursor (buffer place &optional offset)
 103   (with-accessors ((seq sequence-of)
 104                    (size size-of)
 105                    (rcursor read-cursor-of))
 106       buffer
 107     (ecase place
 108       (:start (setf rcursor 0))
 109       (:end   (setf rcursor size))
 110       (:offset
 111        (check-type offset unsigned-byte "an unsigned-byte")
 112        (if (>= offset size)
 113            (error 'input-buffer-index-out-of-bounds :buffer buffer)
 114            (setf rcursor offset))))))
 115
 116 (declaim (inline unread-bytes))
 117 (defun unread-bytes (buffer)
 118   (- (write-cursor-of buffer) (read-cursor-of buffer)))
 119
 120 (defun read-vector (buffer length)
 121   (with-accessors ((seq sequence-of)
 122                    (rcursor read-cursor-of))
 123       buffer
 124     (let* ((bytes-to-read (min (unread-bytes buffer) length))
 125            (newvector (make-array bytes-to-read :element-type 'ub8)))
 126       (replace newvector seq :start2 rcursor)
 127       (incf rcursor bytes-to-read)
 128       (values newvector))))
 129
 130 (defmacro read-ub-be (vector position &optional (length 1))
 131   `(+ ,@(loop :for i :below length
 132               :collect `(ash (aref ,vector (+ ,position ,i))
 133                              ,(* (- length i 1) 8)))))
 134
 135 (declaim (inline read-ub16-from-vector))
 136 (defun read-ub16-from-vector (vector position)
 137   (read-ub-be vector position 2))
 138
 139 (declaim (inline read-ub32-from-vector))
 140 (defun read-ub32-from-vector (vector position)
 141   (read-ub-be vector position 4))
 142
 143 (declaim (inline check-if-enough-bytes))
 144 (defun check-if-enough-bytes (buffer length)
 145   (let ((remaining-bytes (unread-bytes buffer)))
 146     (when (< remaining-bytes length)
 147       (error 'input-buffer-eof
 148              :buffer buffer
 149              :requested length
 150              :remaining remaining-bytes))))
 151
 152 (declaim (inline read-ub8))
 153 (defun read-ub8 (buffer)
 154   (check-if-enough-bytes buffer 1)
 155   (prog1
 156       (aref (sequence-of buffer) (read-cursor-of buffer))
 157     (incf (read-cursor-of buffer))))
 158
 159 (declaim (inline read-ub16))
 160 (defun read-ub16 (buffer)
 161   (check-if-enough-bytes buffer 2)
 162   (prog1
 163       (read-ub16-from-vector (sequence-of buffer) (read-cursor-of buffer))
 164     (incf (read-cursor-of buffer) 2)))
 165
 166 (declaim (inline read-ub32))
 167 (defun read-ub32 (buffer)
 168   (check-if-enough-bytes buffer 4)
 169   (prog1
 170       (read-ub32-from-vector (sequence-of buffer) (read-cursor-of buffer))
 171     (incf (read-cursor-of buffer) 4)))