src/sockets/dns/dynamic-buffer.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Read/write adjustable buffer.
   4 ;;;
   5
   6 (in-package :iolib.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    (growth-threshold :initform 3/2 :accessor growth-threshold-of)))
  13
  14 (defmethod initialize-instance :after ((buffer dynamic-buffer)
  15                                        &key (size 256) sequence (start 0) end)
  16   (etypecase sequence
  17     (null
  18      (setf (sequence-of buffer) (make-array size :element-type 'ub8)))
  19     (ub8-vector
  20      (check-bounds sequence start end)
  21      (let* ((sequence-size (- end start))
  22             (newseq (make-array sequence-size :element-type 'ub8)))
  23        (replace newseq sequence :start2 start :end2 end)
  24        (setf (sequence-of buffer)     newseq
  25              (write-cursor-of buffer) sequence-size)))))
  26
  27 (defmethod print-object ((buffer dynamic-buffer) stream)
  28   (print-unreadable-object (buffer stream :type t :identity t)
  29     (let ((*print-length* 40))
  30       (format stream "Size: ~A RC: ~A WC: ~A Contents: ~S"
  31               (size-of buffer)
  32               (read-cursor-of buffer)
  33               (write-cursor-of buffer)
  34               (sequence-of buffer)))))
  35
  36 (defgeneric size-of (buffer)
  37   (:method ((buffer dynamic-buffer))
  38     (length (sequence-of buffer))))
  39
  40 (declaim (inline ub16-to-vector))
  41 (defun ub16-to-vector (value)
  42   (vector (ldb (byte 8 8) value)
  43           (ldb (byte 8 0) value)))
  44
  45 (declaim (inline ub32-to-vector))
  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 (defun maybe-grow-buffer (buffer vector)
  53   (with-accessors ((seq sequence-of)
  54                    (size size-of)
  55                    (wcursor write-cursor-of)
  56                    (threshold growth-threshold-of))
  57       buffer
  58     (let ((vlen (length vector)))
  59       (when (< size (+ wcursor vlen))
  60         (let ((newsize (* threshold (+ size vlen))))
  61           (setf seq (adjust-array seq newsize))))))
  62   (values buffer))
  63
  64 (defun write-vector (buffer vector)
  65   (maybe-grow-buffer buffer vector)
  66   (with-accessors ((seq sequence-of)
  67                    (wcursor write-cursor-of))
  68       buffer
  69     (let ((vlen (length vector)))
  70       (replace seq vector :start1 wcursor)
  71       (incf wcursor vlen)))
  72   (values buffer))
  73
  74 (declaim (inline write-ub8))
  75 (defun write-ub8 (buffer value)
  76   (write-vector buffer (vector value)))
  77
  78 (declaim (inline write-ub16))
  79 (defun write-ub16 (buffer value)
  80   (write-vector buffer (ub16-to-vector value)))
  81
  82 (declaim (inline write-ub32))
  83 (defun write-ub32 (buffer value)
  84   (write-vector buffer (ub32-to-vector value)))
  85
  86 (define-condition dynamic-buffer-input-error (error)
  87   ((buffer :initform (error "Must supply buffer")
  88            :initarg :buffer :reader buffer-of)))
  89
  90 (define-condition dynamic-buffer-eof (dynamic-buffer-input-error)
  91   ((octets-requested :initarg :requested :reader octets-requested-of)
  92    (octets-remaining :initarg :remaining :reader octets-remaining-of))
  93   (:report (lambda (condition stream)
  94              (format stream "You requested ~A octets but only ~A are left in the buffer"
  95                      (octets-requested-of condition)
  96                      (octets-remaining-of condition))))
  97   (:documentation
  98    "Signals that an INPUT-BUFFER contains less unread bytes than requested."))
  99
 100 (define-condition dynamic-buffer-index-out-of-bounds (dynamic-buffer-input-error)
 101   ((index :initarg :index :reader index-of))
 102   (:report (lambda (condition stream)
 103              (format stream "Trying to access ~A at invalid index ~A"
 104                      (buffer-of condition)
 105                      (index-of condition))))
 106   (:documentation
 107    "Signals that SEEK-READ-CURSOR on an INPUT-BUFFER was passed an invalid index."))
 108
 109 (declaim (inline seek-read-cursor))
 110 (defun seek-read-cursor (buffer index)
 111   (check-type index unsigned-byte "an unsigned-byte")
 112   (if (>= index (size-of buffer))
 113       (error 'dynamic-buffer-index-out-of-bounds :buffer buffer :index index)
 114       (setf (read-cursor-of buffer) index)))
 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 'dynamic-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)))