;;; packet.lisp -- Decode TCP/IP packets (version 1) ;;; Written by Luke Gorrie luke@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)) ,@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)))))