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