[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