[Small-cl-src] packet.lisp, version 1

Luke Gorrie luke at bluetail.com
Mon May 24 03:33:55 UTC 2004


;;; packet.lisp -- Decode TCP/IP packets (version 1)
;;; Written by Luke Gorrie <luke at bluetail.com> in May of 2004.
;;;
;;; A PDF version of this source file can be found at:
;;;   http://www.bluetail.com/~luke/misc/lisp/packet.pdf
;;;
;;;# Introduction
;;;
;;; This is a program for decoding the packet headers of some TCP/IP
;;; family protocols. It takes a packet (represented as a vector),
;;; decodes all the headers it can, and returns the results in either
;;; association-lists or strucutres.
;;;
;;; This program is a library; it's not very useful in itself.
;;;
;;; Written for recent snapshots of CMUCL. I've used some minor
;;; non-portable features: `ext:collect', `slot-value' on structures,
;;; and (cons T1 T2) type specifiers.

(defpackage :packet
  (:use :common-lisp))

(in-package :packet)

;;;# Top-level interface
;;;
;;; The input for this program is a `buffer' containing an ethernet
;;; frame.
;;;
(deftype buffer ()
  "A network packet represented as a vector of octets."
  '(array octet (*)))

(deftype octet ()
  "An unsigned 8-bit byte."
  '(unsigned-byte 8))

;;; The program's output is a list of headers that have been decoded
;;; from a buffer. Headers can be represented either as structures or
;;; as association lists, depending on what you'd like.
;;;
(deftype header ()
  "A decoded protocol header."
  '(or structure-header alist-header))

;;; The structure definition for each protocol header is defined down
;;; below in the same section of code that does the decoding.
;;;
(deftype structure-header ()
  "A decoded protocol header represented as a structure."
  '(or ethernet-header arp-header ipv4-header udp-header))

(deftype alist-header ()
  "A decoded protocol header with fields in an alist.
The format is (TYPE-NAME ALIST).
TYPE-NAME is the name of the corresponding structure-header."
  '(cons symbol cons))

;;; The function `decode' takes a buffer containing a frame and
;;; returns a list of the headers it was able to decode.
;;;
(defun decode (buffer format)
  "Decode headers from BUFFER and return them in a list.
The headers are decoded into FORMAT, which can be either :STRUCTURE or
:ALIST.

Any remaining undecoded data is included as a vector at the end of the
list."
  (grab-headers buffer format))

;;;# Low-level data-grabbing machinery

(declaim (type (or null buffer) *buffer*))
(defvar *buffer* nil
  "Buffer containing the packet currently being decoded.")

(defvar *buffer-position* nil
  "Current bit-position in *BUFFER*.")

(defmacro with-buffer (buffer &body body)
  "Execute BODY, grabbing input from the beginning of BUFFER."
  `(let ((*buffer* ,buffer)
         (*buffer-position* 0))
    , at body))

(defun bit-octet (bit &optional (check-alignment t))
  "Convert from bit position to octet position."
  (multiple-value-bind (quotient remainder) (truncate bit 8)
    (when (and check-alignment (plusp remainder))
      (error "Bit-position ~S is not octet-aligned." bit))
    quotient))

(defun octet-bit (octet)
  "Convert from octet position to bit position."
  (* 8 octet))

;;; "Grab" functions consume input from `*buffer*' and advance
;;; `*buffer-position*'.

(defun grab-octets (num)
  "Grab a vector of NUM octets."
  (let ((start (bit-octet *buffer-position*)))
    (incf *buffer-position* (* num 8))
    (subseq *buffer* start (+ num start))))

(defun grab-ethernet-address ()
  (make-ethernet-address :octets (grab-octets 6)))

(defun grab-ipv4-address ()
  (make-ipv4-address :octets (grab-octets 4)))

(defun grab-rest ()
  "Grab the rest of the buffer into an octet vector."
  (prog1 (subseq *buffer* (bit-octet *buffer-position*))
    (setf *buffer-position* (octet-bit (length *buffer*)))))

;;; I've written this function countless times but it always comes out
;;; ugly. What's the right way?
(defun grab-bits (bits)
  "Grab a BITS-long unsigned integer"
  (let ((accumulator 0)
        (remaining bits))
    (flet ((accumulate-byte ()
             ;; Accumulate the relevant part of the current byte and
             ;; advance to the next one.
             (let* ((size (min remaining (- 8 (rem *buffer-position* 8))))
                    (offset (rem (- 8 (rem (+ *buffer-position* size) 8)) 8))
                    (value (ldb (byte size offset)
                                (aref *buffer*
                                      (bit-octet *buffer-position* nil)))))
               (decf remaining size)
               (setf accumulator
                     (dpb value (byte size remaining) accumulator))
               (incf *buffer-position* size))))
      (loop while (plusp remaining)
            do (accumulate-byte))
      accumulator)))

(defun grab-bitflag ()
  "Grab a single bit. Return T if it's 1 and NIL if it's 0."
  (= (grab-bits 1) 1))

;;;# Protocol implementations
;;;
;;; The interface to each protocol is `(map-<protocol>-header
;;; FUNCTION)'. Function takes two arguments: a header name and its
;;; value. The function is called for each decoded header. It can
;;; accumulate the values any way it likes.

(defvar *resolve-protocols* t
  "When non-nil protocol numbers are resolved to symbolic names.
Unrecognised numbers are left as numbers.")

(defvar *verify-checksums* t
  "When non-nil verify checksums in packets.")

(deftype checksum-ok-p ()
  "The status of a packet's checksum.
T means the checksum is correct, NIL means it is wrong, and :UNKNOWN
means it hasn't been checked."
  '(member t nil :unknown))

(defun lookup (key alist &key (errorp t) (reversep nil))
  "Lookup the value of KEY in ALIST.
If the key is not present and ERRORP is true then an error is
signalled; if ERRORP is nil then the key itself is returned."
  (let ((entry (funcall (if reversep #'rassoc #'assoc) key alist)))
    (cond (entry  (funcall (if reversep #'car #'cdr) entry))
          (errorp (error "Key ~S is not present in ~A." key alist))
          (t      key))))

;;;## Ethernet

;;;### ethernet-address
;;;
;;; This big `eval-when' is needed to define the read-syntax for
;;; `ethernet-address' such that it can be used in this file.
;;;
;;; The read syntax is `#e"ff:00:1:2:3:4'.
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defstruct (ethernet-address (:conc-name #:ethernet-address.)
                               (:print-function print-ethernet-address))
    "48-bit Ethernet MAC address."
    (octets (ext:required-argument) :type (array octet (6))))

  (defun read-ethernet-address (stream &optional c n)
    "Read an ethernet address in colon-separated syntax.
     Example: #e\"1:2:3:4:5:6\""
    (declare (ignore c n))
    (let ((value-stream (make-string-input-stream (read stream t nil t)))
          (*readtable* (copy-readtable))
          (*read-base* 16))
      (set-syntax-from-char #\: #\Space)
      (let ((vec (make-array '(6) :element-type 'octet)))
        (dotimes (i 6)
          (let ((octet (read value-stream t nil t)))
            (unless *read-suppress*
              (setf (elt vec i) octet))))
        (unless *read-suppress*
          (make-ethernet-address :octets vec)))))
  
  (set-dispatch-macro-character #\# #\e 'read-ethernet-address)

  (defun print-ethernet-address (address stream depth)
    "Print ethernet addresses as in #e\"0:ff:1:2:3:4\"."
    (declare (ignore depth))
    (format stream "#e\"~{~16,2,'0R~^:~}\""
            (coerce (ethernet-address.octets address) 'list)))

  (defmethod make-load-form ((s ethernet-address) &optional env)
    (make-load-form-saving-slots s :environment env)))

;;;### Decoder

(defstruct (ethernet-header (:conc-name #:ethernet-header.))
  (dest     nil :type (or null ethernet-address))
  (source   nil :type (or null ethernet-address))
  (protocol nil :type (or null (unsigned-byte 16) symbol)))

(defvar ethernet-protocol-names '((#x0806 . :arp) (#x0800 . :ipv4))
  "Mapping from ethernet protocol numbers to symbolic names.")

(defun map-ethernet-header (function)
  "Grab an ethernet header and call FUNCTION with each part."
  (flet ((header (name value) (funcall function name value)))
    (header 'dest     (grab-ethernet-address))
    (header 'source   (grab-ethernet-address))
    (header 'protocol (ethernet-protocol-name (grab-bits 16)))))

(defun ethernet-protocol-name (number)
  "Return the symbolic protocol name of NUMBER, if appropriate."
  (if *resolve-protocols*
      (lookup number ethernet-protocol-names :errorp nil)
      number))

;;;## ARP

(defstruct (arp-header (:conc-name #:arp-header.))
  (hardware-type   nil :type (or null (unsigned-byte 16)))
  (protocol-type   nil :type (or null (unsigned-byte 16)))
  (hardware-length nil :type (or null (unsigned-byte 8)))
  (protocol-length nil :type (or null (unsigned-byte 8)))
  (operation       nil :type (or null symbol (unsigned-byte 16)))
  (sender-ha       nil :type (or null ethernet-address))
  (sender-ip       nil :type (or null ipv4-address))
  (target-ha       nil :type (or null ethernet-address))
  (target-ip       nil :type (or null ipv4-address)))

(defun map-arp-header (function)
  "Grab an ARP header and call FUNCTION with each part."
  (flet ((header (name value) (funcall function name value)))
    (header 'hardware-type (grab-bits 16))
    (header 'protocol-type (grab-bits 16))
    (header 'hardware-length (grab-bits 8))
    (header 'protocol-length (grab-bits 8))
    (header 'operation (arp-operation (grab-bits 16)))
    (header 'sender-ha (grab-ethernet-address))
    (header 'sender-ip (grab-ipv4-address))
    (header 'target-ha (grab-ethernet-address))
    (header 'target-ip (grab-ipv4-address))))

(defvar arp-operation-names '((1 . :request) (2 . :response))
  "Mapping between ARP operation numbers and their symbolic names.")

(defun arp-operation (operation)
  "Return the symbolic name for OPERATION, if appropriate."
  (if *resolve-protocols*
      (lookup operation arp-operation-names :errorp nil)
      operation))

;;;## IPv4
;;;
;;; The Internet Protocol is described in RFC791.
;;;
;;;### ipv4-address
;;;
;;; IP addresses also have a special read-syntax: `@10.0.0.1'.
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defstruct (ipv4-address (:conc-name #:ipv4-address.)
                           (:print-function print-ipv4-address))
    (octets (ext:required-argument) :type (array octet (4))))

  (defun read-ipv4-address (stream &optional c n)
    "Read an IPv4 address in dotted-quad format.
     Example: @192.168.0.1"
    (declare (ignore c n))
    (let ((*readtable* (copy-readtable)))
      (set-syntax-from-char #\. #\Space)
      (let ((vec (make-array '(4) :element-type 'octet)))
        (dotimes (i 4)
          (let ((octet (read stream t nil t)))
            (unless *read-suppress*
              (setf (elt vec i) octet))))
        (unless *read-suppress*
          (make-ipv4-address :octets vec)))))
  
  (set-macro-character #\@ 'read-ipv4-address t)

  (defun print-ipv4-address (address stream depth)
    "Print IPv4 addresses as in @192.168.0.1."
    (declare (ignore depth))
    (format stream "@~{~A~^.~}" (coerce (ipv4-address.octets address) 'list)))
  
  (defmethod make-load-form ((s ipv4-address) &optional env)
    (make-load-form-saving-slots s :environment env)))

;;;### decoder

(defstruct (ipv4-header (:conc-name #:ipv4-header.))
  (version         nil :type (or null (unsigned-byte 4)))
  (hlen            nil :type (or null (unsigned-byte 4)))
  (tos             nil :type (or null (unsigned-byte 8)))
  (total-len       nil :type (or null (unsigned-byte 16)))
  (id              nil :type (or null (unsigned-byte 16)))
  (flags           nil :type (or null (unsigned-byte 3)))
  (fragment-offset nil :type (or null (unsigned-byte 13)))
  (ttl             nil :type (or null (unsigned-byte 8)))
  (protocol        nil :type (or null symbol (unsigned-byte 8)))
  (checksum        nil :type (or null (unsigned-byte 16)))
  (source          nil :type (or null ipv4-address))
  (dest            nil :type (or null ipv4-address))
  ;; Synthetic:
  (checksum-ok-p   nil :type checksum-ok-p))

(defconstant ipv4-min-hlen 5
  "The header length (in 32-bit words) of an IPv4 packet with no options.")

(defun map-ipv4-header (function)
  (flet ((header (name value) (funcall function name value)))
    (let ((header-start-pos (bit-octet *buffer-position*))
          hlen
          checksum)
      (header 'version         (grab-bits 4))
      (header 'hlen            (setf hlen (grab-bits 4)))
      (header 'tos             (grab-bits 8))
      (header 'total-len       (grab-bits 16))
      (header 'id              (grab-bits 16))
      (header 'flags           (grab-bits 3))
      (header 'fragment-offset (grab-bits 13))
      (header 'ttl             (grab-bits 8))
      (header 'protocol        (if *resolve-protocols*
                                   (ipv4-protocol (grab-bits 8))
                                 (grab-bits 8)))
      (header 'checksum        (setf checksum (grab-bits 16)))
      (header 'source          (grab-ipv4-address))
      (header 'dest            (grab-ipv4-address))
      ;; FIXME
      (unless (= hlen ipv4-min-hlen)
        (error "Can't decode options in IPv4 packets."))
      (if *verify-checksums*
          (let* ((initial (- checksum))
                 (header-octets (* hlen 4))
                 (computed-checksum
                  (checksum *buffer* header-start-pos header-octets initial)))
            (header 'checksum-ok-p (eql checksum computed-checksum)))
          (header 'checksum-ok-p :unknown)))))

(defvar ipv4-protocol-names '((1 . :icmp) (6 . :tcp) (17 . :udp))
  "Mapping between IPv4 protocol numbers and their symbolic names.")

(defun ipv4-protocol (number)
  "Return the symbolic name for protocol NUMBER, if appropriate."
  (if *resolve-protocols*
      (lookup number ipv4-protocol-names :errorp nil)
      number))

;;;## UDP

;;; RFC 768

(defstruct (udp-header (:conc-name #:udp-header.))
  (src-port      nil :type (or null (unsigned-byte 16)))
  (dest-port     nil :type (or null (unsigned-byte 16)))
  (length        nil :type (or null (unsigned-byte 16)))
  (checksum      nil :type (or null (unsigned-byte 16)))
  (checksum-ok-p nil :type checksum-ok-p))

(defun map-udp-header (function &optional src-ip dest-ip)
  "Grab a UDP header and call FUNCTION with each part.
The checksum can only be checked if the SRC-IP and DEST-IP fields from
the IPv4 header are supplied."
  (flet ((header (name value) (funcall function name value)))
    (let ((header-start (bit-octet *buffer-position*))
          checksum length)
    (header 'src-port  (grab-bits 16))
    (header 'dest-port (grab-bits 16))
    (header 'length    (setf length (grab-bits 16)))
    (header 'checksum  (setf checksum (grab-bits 16)))
    (if (and *verify-checksums* src-ip dest-ip)
        (or (zerop checksum)            ; checksum is optional
            (let ((init (- (udp-pseudo-header-checksum-acc
                            src-ip dest-ip length)
                           checksum)))
              (header 'checksum-ok-p
                      (= checksum
                         (checksum *buffer* header-start length init)))))
        (header 'checksum-ok-p :unknown)))))

(defun udp-pseudo-header-checksum-acc (src-ip dest-ip udp-length)
  (+ (checksum-acc-ipv4-address src-ip)
     (checksum-acc-ipv4-address dest-ip)
     (lookup :udp ipv4-protocol-names :reversep t)
     udp-length))

;;;# Checksum computation
;;;
;;; The TCP/IP protocols use 16-bit ones-complement checksums. See
;;; RFC1071 for details.

(defun checksum (buffer &optional
                 (position 0) (length (length buffer)) (initial 0))
  "Compute the checksum of a region in BUFFER.
POSITION and LENGTH are both in octets.

INITIAL is the initial checksum value as a normal integer."
  (finish-checksum (compute-checksum buffer position length initial)))

(defun compute-checksum (buffer &optional
                         (position 0) (length (length buffer)) (initial 0))
  "Compute a checksum using normal twos-complement arithmetic.
The buffer is treated as a sequence of 16-bit big-endian numbers."
  (declare (type buffer buffer))
  (let ((last-pos (+ position (1- length)))
        (acc initial))
    (do ((msb-pos position      (+ msb-pos 2))
         (lsb-pos (1+ position) (+ lsb-pos 2)))
        ((> lsb-pos last-pos) acc)
      (let ((lsb (aref buffer lsb-pos))
            (msb (if (> msb-pos last-pos) 0 (aref buffer msb-pos))))
        (incf acc (dpb msb (byte 8 8) lsb))))))

(defun checksum-acc-ipv4-address (address)
  "Return the partial checksum accumulated from an IPv4 address."
  (compute-checksum (ipv4-address.octets address)))

(defun finish-checksum (n)
  "Convert N into an unsigned 16-bit ones-complement number.
The result is a bit-pattern also represented as an integer."
  (let* ((acc (+ (ldb (byte 16 16) n)
                 (ldb (byte 16 0) n)))
         (acc (+ acc (ldb (byte 16 16) acc))))
    (logxor #xFFFF (ldb (byte 16 0) acc))))

;;;# Creating headers

(defun grab-header-into-alist (type)
  "Grab a header of TYPE into an `alist-header'."
  (ext:collect ((fields))
    (funcall (mapping-function type)
             (lambda (header value)
               (fields (cons header value))))
    (fields)))

(defun grab-header-into-structure (type)
  "Grab a header of TYPE into a `structure-header'."
  (let ((structure (make-instance type)))
    (funcall (mapping-function type)
             (lambda (slot value)
               (setf (slot-value structure slot) value)))
    structure))

;;;# Header-decoding driver

(defvar *format* nil
  "Which format to decode headers in, either :STRUCTURE or :ALIST.")

(defvar *previous-header* nil
  "Bound to the previously decoded header.
Some protocols (e.g. UDP) need to retrieve fields from their enclosing
protocol's header.")

(defun grab-headers (buffer format)
  "Return a list of decoded headers from BUFFER in FORMAT."
  (with-buffer buffer
    (let* ((*format* format)
           (headers (grab-more-headers (grab-header :ethernet)))
           (rest (grab-rest)))
      (if (zerop (length rest))
          headers
          (append headers (list rest))))))

(defun grab-more-headers (header)
  "Accumulate HEADER and continue decoding the rest."
  (let ((*previous-header* header))
    (if (member (header-type header) '(ethernet-header ipv4-header))
        (let ((inner-protocol (get-header-field header 'protocol)))
          (cons header (grab-more-headers (grab-header inner-protocol))))
        ;; This is the last header we know how to decode.
        (list header))))

(defun grab-header (protocol)
  "Grab and return the header of PROTOCOL."
  (let ((type (structure-type-for-protocol protocol)))
    (ecase *format*
      (:alist
       (make-alist-header type (grab-header-into-alist type)))
      ((:structure)
       (grab-header-into-structure type)))))

(defun make-alist-header (type fields-alist)
  "Make an `alist-header'."
  (list type fields-alist))

(defvar protocol-header-types
  '((:ethernet . ethernet-header) (:ipv4 . ipv4-header)
    (:arp      . arp-header)      (:udp  . udp-header))
  "Association list matching protocol names with their header types.")

(defun structure-type-for-protocol (protocol)
  "Lookup the header type for PROTOCOL."
  (lookup protocol protocol-header-types))

(defun header-type (header)
  "Return the type of HEADER.
This is the name of the corresponding structure-type, even if the
header is in alist format."
  (etypecase header
    (alist-header     (first header))
    (structure-header (type-of header))))

(defun get-header-field (header field)
  "Return the value of FIELD in HEADER."
  (declare (type header header))
  (etypecase header
    (alist-header     (cdr (assoc field (second header))))
    (structure-header (slot-value header field))))

(defun mapping-function (type)
  "Return the appropriate field-mapping function for TYPE."
  (ecase type
    (ethernet-header #'map-ethernet-header)
    (arp-header      #'map-arp-header)
    (ipv4-header     #'map-ipv4-header)
    (udp-header
     ;; Pass on the IP addresses for checksum computation.
     (let ((src-ip  (get-header-field *previous-header* 'source))
           (dest-ip (get-header-field *previous-header* 'dest)))
       (lambda (function)
         (map-udp-header function src-ip dest-ip))))))

;;;# Sample packets

(defvar arp-packet
  (coerce
   #(255 255 255 255 255 255 0 8 116 228 110 188 8 6 0 1 8 0 6 4 0 1 0 8 116
     228 110 188 192 168 128 44 0 0 0 0 0 0 192 168 128 1)
   'buffer)
  "An ethernet frame containing an ARP request.")

(defvar udp-packet
  (coerce
   #(255 255 255 255 255 255 0 8 116 228 110 188 8 0 69 0 0 124 0 0 64 0 64
     17 183 244 192 168 128 44 192 168 128 255 128 117 0 111 0 104 5 206 20
     15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0 2 0 0 0 5 0 0 0 1 0 0 0 24
     64 158 126 39 0 0 0 4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
     0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0 0 0 12 98 108 117 101 116
     97 105 108 46 99 111 109)
   'buffer)
  "An ethernet frame containing a UDP packet.")

(defun test ()
  "Test that the sample packets are decoded correctly."
  (let ((alist-arp (decode arp-packet :alist))
        (alist-udp (decode udp-packet :alist))
        (struct-arp (decode arp-packet :structure))
        (struct-udp (decode udp-packet :structure)))
    (assert (equalp alist-arp
                    '((ETHERNET-HEADER
                       ((DEST            . #e"FF:FF:FF:FF:FF:FF")
                        (SOURCE          . #e"00:08:74:E4:6E:BC")
                        (PROTOCOL        . :ARP)))
                      (ARP-HEADER
                       ((HARDWARE-TYPE   . 1)
                        (PROTOCOL-TYPE   . 2048)
                        (HARDWARE-LENGTH . 6)
                        (PROTOCOL-LENGTH . 4)
                        (OPERATION       . :REQUEST)
                        (SENDER-HA       . #e"00:08:74:E4:6E:BC")
                        (SENDER-IP       . @192.168.128.44)
                        (TARGET-HA       . #e"00:00:00:00:00:00")
                        (TARGET-IP       . @192.168.128.1))))))
    (assert (equalp alist-udp
                    `((ETHERNET-HEADER
                       ((DEST            . #e"FF:FF:FF:FF:FF:FF")
                        (SOURCE          . #e"00:08:74:E4:6E:BC")
                        (PROTOCOL        . :IPV4)))
                      (IPV4-HEADER
                       ((VERSION         . 4)
                        (HLEN            . 5)
                        (TOS             . 0)
                        (TOTAL-LEN       . 124)
                        (ID              . 0)
                        (FLAGS           . 2)
                        (FRAGMENT-OFFSET . 0)
                        (TTL             . 64)
                        (PROTOCOL        . :UDP)
                        (CHECKSUM        . 47092)
                        (SOURCE          . @192.168.128.44)
                        (DEST            . @192.168.128.255)
                        (CHECKSUM-OK-P   . T)))
                      (UDP-HEADER
                       ((SRC-PORT        . 32885)
                        (DEST-PORT       . 111)
                        (LENGTH          . 104)
                        (CHECKSUM        . 1486)
                        (CHECKSUM-OK-P   . T)))
                      ,(coerce
                        #(20 15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0
                          2 0 0 0 5 0 0 0 1 0 0 0 24 64 158 126 39 0 0 0
                          4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
                          0 0 0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0
                          0 0 12 98 108 117 101 116 97 105 108 46 99 111 109)
                        'buffer))))
    (assert (equivalentp alist-arp struct-arp))
    (assert (equivalentp alist-udp struct-udp))
    t))

(defun equivalentp (alist-headers structure-headers)
  "Do ALIST-HEADERS and STRUCTURE-HEADERS have the same slot values?"
  (if (and (null alist-headers) (null structure-headers))
      t
      (destructuring-bind ((ah &rest arest) (sh &rest srest))
          (list alist-headers structure-headers)
        (and (cond ((and (typep ah 'buffer) (typep sh 'buffer))
                    (equalp ah sh))
                   ((eq (header-type ah) (header-type sh))
                    (loop for (key . value) in (second ah)
                          always (equalp (slot-value sh key) value))))
             (equivalentp arest srest)))))





More information about the Small-cl-src mailing list