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
  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 (defgeneric size-of (buffer)
  36   (:method ((buffer dynamic-buffer))
  37     (length (sequence-of buffer))))
  38
  39 (declaim (inline ub16-to-vector))
  40 (defun ub16-to-vector (value)
  41   (vector (ldb (byte 8 8) value)
  42           (ldb (byte 8 0) value)))
  43
  44 (declaim (inline ub32-to-vector))
  45 (defun ub32-to-vector (value)
  46   (vector (ldb (byte 8 32) value)
  47           (ldb (byte 8 16) value)
  48           (ldb (byte 8 8) value)
  49           (ldb (byte 8 0) value)))
  50
  51 (defun maybe-grow-buffer (buffer vector)
  52   (with-accessors ((seq sequence-of)
  53                    (size size-of)
  54                    (wcursor write-cursor-of))
  55       buffer
  56     (let ((vlen (length vector)))
  57       (when (< size (+ wcursor vlen))
  58         (let ((newsize (* 3/2 (+ size vlen))))
  59           (setf seq (adjust-array seq newsize))))))
  60   (values buffer))
  61
  62 (defun write-vector (buffer vector)
  63   (maybe-grow-buffer buffer vector)
  64   (with-accessors ((seq sequence-of)
  65                    (wcursor write-cursor-of))
  66       buffer
  67     (let ((vlen (length vector)))
  68       (replace seq vector :start1 wcursor)
  69       (incf wcursor vlen)))
  70   (values buffer))
  71
  72 (declaim (inline write-ub8))
  73 (defun write-ub8 (buffer value)
  74   (write-vector buffer (vector value)))
  75
  76 (declaim (inline write-ub16))
  77 (defun write-ub16 (buffer value)
  78   (write-vector buffer (ub16-to-vector value)))
  79
  80 (declaim (inline write-ub32))
  81 (defun write-ub32 (buffer value)
  82   (write-vector buffer (ub32-to-vector value)))
  83
  84 (define-condition dynamic-buffer-input-error (error)
  85   ((buffer :initform (error "Must supply buffer")
  86            :initarg :buffer :reader buffer-of)))
  87
  88 (define-condition dynamic-buffer-eof (dynamic-buffer-input-error)
  89   ((octets-requested :initarg :requested :reader octets-requested-of)
  90    (octets-remaining :initarg :remaining :reader octets-remaining-of))
  91   (:report (lambda (condition stream)
  92              (format stream "You requested ~A octets but only ~A are left in the buffer"
  93                      (octets-requested-of condition)
  94                      (octets-remaining-of condition))))
  95   (:documentation
  96    "Signals that an INPUT-BUFFER contains less unread bytes than requested."))
  97
  98 (define-condition dynamic-buffer-index-out-of-bounds (dynamic-buffer-input-error)
  99   ((index :initarg :index :reader index-of))
 100   (:report (lambda (condition stream)
 101              (format stream "Trying to access ~A at invalid index ~A"
 102                      (buffer-of condition)
 103                      (index-of condition))))
 104   (:documentation
 105    "Signals that SEEK-READ-CURSOR on an INPUT-BUFFER was passed an invalid index."))
 106
 107 (declaim (inline seek-read-cursor))
 108 (defun seek-read-cursor (buffer index)
 109   (check-type index unsigned-byte "an unsigned-byte")
 110   (if (>= index (size-of buffer))
 111       (error 'dynamic-buffer-index-out-of-bounds :buffer buffer :index index)
 112       (setf (read-cursor-of buffer) index)))
 113
 114 (declaim (inline unread-bytes))
 115 (defun unread-bytes (buffer)
 116   (- (write-cursor-of buffer) (read-cursor-of buffer)))
 117
 118 (defun read-vector (buffer length)
 119   (with-accessors ((seq sequence-of)
 120                    (rcursor read-cursor-of))
 121       buffer
 122     (let* ((bytes-to-read (min (unread-bytes buffer) length))
 123            (newvector (make-array bytes-to-read :element-type 'ub8)))
 124       (replace newvector seq :start2 rcursor)
 125       (incf rcursor bytes-to-read)
 126       (values newvector))))
 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 (declaim (inline read-ub16-from-vector))
 134 (defun read-ub16-from-vector (vector position)
 135   (read-ub-be vector position 2))
 136
 137 (declaim (inline read-ub32-from-vector))
 138 (defun read-ub32-from-vector (vector position)
 139   (read-ub-be vector position 4))
 140
 141 (declaim (inline check-if-enough-bytes))
 142 (defun check-if-enough-bytes (buffer length)
 143   (let ((remaining-bytes (unread-bytes buffer)))
 144     (when (< remaining-bytes length)
 145       (error 'dynamic-buffer-eof
 146              :buffer buffer
 147              :requested length
 148              :remaining remaining-bytes))))
 149
 150 (declaim (inline read-ub8))
 151 (defun read-ub8 (buffer)
 152   (check-if-enough-bytes buffer 1)
 153   (prog1
 154       (aref (sequence-of buffer) (read-cursor-of buffer))
 155     (incf (read-cursor-of buffer))))
 156
 157 (declaim (inline read-ub16))
 158 (defun read-ub16 (buffer)
 159   (check-if-enough-bytes buffer 2)
 160   (prog1
 161       (read-ub16-from-vector (sequence-of buffer) (read-cursor-of buffer))
 162     (incf (read-cursor-of buffer) 2)))
 163
 164 (declaim (inline read-ub32))
 165 (defun read-ub32 (buffer)
 166   (check-if-enough-bytes buffer 4)
 167   (prog1
 168       (read-ub32-from-vector (sequence-of buffer) (read-cursor-of buffer))
 169     (incf (read-cursor-of buffer) 4)))