changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/net/codec/tlv.lisp

changeset 698: 96958d3eb5b0
parent: 386d51cf61ca
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; lisp/net/codec/tlv.lisp --- TypeLengthValue wire codec
     2 
     3 ;;
     4 
     5 ;;; Code:
     6 (in-package :net/codec/tlv)
     7 
     8 (defclass tlv ()
     9   ((type :initform 0 :initarg :type :type octet :accessor tlv-type)
    10    (length :initform 0 :initarg :length :type (unsigned-byte 16) :accessor tlv-length)
    11    (value :initform (make-array 0 :element-type 'octet) :initarg :value :type octet-vector :accessor tlv-value))
    12   (:documentation "TypeLengthValue object.
    13 
    14 TLVs are a common packet format in communication protocols. Objects of
    15 this type are assumed to have a 1 byte TYPE, a 2 byte LENGTH, and a
    16 VALUE which is an OCTET-VECTOR of length LENGTH."))
    17 
    18 (defmethod serialize ((obj tlv) (format (eql :bytes)) &key stream)
    19   (declare (ignore format))
    20   (with-slots (type length value) obj
    21     (let* ((end (+ 3 length))
    22            (buf (make-array end :element-type 'octet)))
    23       (setf (aref buf 0) type)
    24       (setf (subseq buf 1 2) (integer-to-octets length 16))
    25       (unless (= 0 length)
    26         (setf (subseq buf 3 (+ 3 length)) value))
    27       (if stream
    28           (write buf :stream stream)
    29           buf))))
    30 
    31 (defun make-tlv (type length &optional (value #.(make-array 0 :element-type 'octet)))
    32   (make-instance 'tlv :type type :length length :value value))
    33 
    34 (defmethod serialize ((obj tlv) (format (eql :string)) &key stream (external-format :default))
    35   (declare (ignore format stream))
    36   (sb-ext:octets-to-string (serialize obj :bytes) :external-format external-format))
    37 
    38 (defmethod deserialize ((from simple-array) (format (eql :tlv)) &key)
    39   (declare (ignore format))
    40   (let ((type (aref from 0))
    41         (length (octets-to-integer (subseq from 1 3))))
    42     (if (= 0 length)
    43         (make-tlv type length)
    44         (let ((value (subseq from 3 (+ 3 length))))
    45           (funcall #'make-tlv type length value)))))
    46 
    47 (defmethod deserialize ((from stream) (format (eql :tlv)) &key)
    48   (let ((type (read-byte from))
    49         (l (make-array 2 :element-type 'octet :adjustable t)))
    50     (read-sequence l from)
    51     (let ((length (octets-to-integer (coerce l 'octet-vector))))
    52       (if (= 0 length)
    53           (make-tlv type length nil)
    54           (let ((value (make-array length :element-type 'octet)))
    55             (read-sequence value from)
    56             (make-tlv type length value))))))
    57 
    58 (defmethod serde ((from tlv) (to simple-array))
    59   (with-slots (type length value) from
    60     (setf (aref to 0) type)
    61     (replace to (integer-to-octets length 16) :start1 1 :start2 2)
    62     (unless (= 0 length)
    63       (replace to value :start1 3 :end1 (+ 3 length)))
    64     to))
    65 
    66 (defmethod serde ((from simple-array) (to tlv))
    67   (if (> 3 (length from))
    68       (error 'serde-error :message "array length is < 3")
    69       (let ((type (aref from 0))
    70             (length (octets-to-integer (subseq from 1 2))))
    71         (setf (tlv-type to) type
    72               (tlv-length to) length
    73               (tlv-value to) (subseq from 3 (+ 3 length)))
    74         to)))
    75 #+nil
    76 (describe
    77  (deserialize
    78   (serialize (make-instance 'tlv) :bytes)
    79   :tlv))