small-cl-src July 2004

small-cl-src@common-lisp.net

5 participants
5 discussions

[Small-cl-src] bit I/O
by Zach Beane 27 Aug '04

27 Aug '04

;;;; The following stuff is taken, verbatim and somewhat unpolished, ;;;; from something I'm currently working on. ;;;; ;;;; Bit-level I/O. The Flash spec has various structures packed into ;;;; bit fields. ;;;; ;;;; $Id: bitio.lisp,v 1.5 2004/07/08 02:47:20 xach Exp $ (in-package :flash) (defclass bitstream () ((current-byte :initarg :current-byte :accessor current-byte) (bits-left :initarg :bits-left :accessor bits-left) (stream :initarg :stream :reader stream)) (:documentation "A class for writing or reading bits to or from an (UNSIGNED-BYTE 8) stream.")) ;;; Input (defun make-input-bitstream (stream &key (current-byte 0) (bits-left 0)) "Return a bitstream suitable for reading. The CURRENT-BYTE and BITS-LEFT, if specified, initialize the internal byte buffer and count." (assert (input-stream-p stream)) (assert (subtypep (stream-element-type stream) '(unsigned-byte 8))) (make-instance 'bitstream :stream stream :current-byte current-byte :bits-left bits-left)) (defmethod read-bits (width (bitstream bitstream) &optional (signedp nil)) (with-accessors ((bits-left bits-left) (input stream) (current-byte current-byte)) bitstream (loop with result = 0 with bits-needed = width while (plusp bits-needed) if (> bits-needed bits-left) do (setf result (logior (ash result bits-left) (ldb (byte bits-left 0) current-byte)) bits-needed (- bits-needed bits-left) current-byte (read-byte input) bits-left 8) else do (setf result (logior (ash result bits-needed) (ldb (byte bits-needed (- bits-left bits-needed)) current-byte)) bits-left (- bits-left bits-needed) bits-needed 0) finally (if (and signedp (logbitp (1- width) result)) (return (1- (- (logandc2 (1- (ash 1 width)) result)))) (return result))))) (defmethod read-boolean ((bitstream bitstream)) "Read and return a single bit from BITSTREAM as a boolean." (logbitp 0 (read-bits 1 bitstream))) (defmacro with-input-bitstream ((bitstream stream &key (current-byte 0) (bits-left 0)) &body body) "Evaluate BODY with a newly-created input bitstream bound to BITSTREAM." (let ((-current-byte- (gensym)) (-bits-left- (gensym))) `(let* ((,-current-byte- ,current-byte) (,-bits-left- ,bits-left) (,bitstream (make-input-bitstream ,stream :current-byte ,-current-byte- :bits-left ,-bits-left-))) ,@body))) ;;; Output (defun make-output-bitstream (stream &key (current-byte 0) (bits-left 8)) "Return a bitstream suitable for writing. The CURRENT-BYTE and BITS-LEFT, if specified, initialize the internal byte buffer and count." (assert (output-stream-p stream)) (assert (subtypep (stream-element-type stream) '(unsigned-byte 8))) (make-instance 'bitstream :stream stream :current-byte current-byte :bits-left bits-left)) (defmethod write-bits (integer width (bitstream bitstream)) "Write the rightmost WIDTH bits from INTEGER to the bitstream" (with-accessors ((bits-left bits-left) (stream stream) (current-byte current-byte)) bitstream (when (minusp integer) (setf integer (ldb (byte width 0) integer))) (loop with bits-needed = width while (plusp bits-needed) if (> bits-needed bits-left) do (setf (ldb (byte bits-left 0) current-byte) (ldb (byte bits-left (- bits-needed bits-left)) integer) bits-needed (- bits-needed bits-left)) (write-byte current-byte stream) (setf current-byte 0 bits-left 8) else do (setf (ldb (byte bits-needed (- bits-left bits-needed)) current-byte) (ldb (byte bits-needed 0) integer) bits-left (- bits-left bits-needed) bits-needed 0)))) (defmethod write-bit (bit (bitstream bitstream)) "Write a single bit to the bitstream." (write-bits bit 1 bitstream)) (defmethod write-boolean (boolean (bitstream bitstream)) "Write BOOLEAN as a bit to the bitstream." (if boolean (write-bit 1 bitstream) (write-bit 0 bitstream))) (defmethod finish-write ((bitstream bitstream)) "Flush the output buffer byte of BITSTREAM. Uninitialized bits are written as 0." (when (< (bits-left bitstream) 8) (write-byte (current-byte bitstream) (stream bitstream)) (setf (current-byte bitstream) 0) (setf (bits-left bitstream) 8))) (defmacro with-output-bitstream ((bitstream stream &key (current-byte 0) (bits-left 8)) &body body) "Evaluate BODY with a newly-created output bitstream bound to BITSTREAM. Pending output is flushed at the end of evaluation." (let ((-current-byte- (gensym)) (-bits-left- (gensym))) `(let* ((,-current-byte- ,current-byte) (,-bits-left- ,bits-left) (,bitstream (make-output-bitstream ,stream :current-byte ,-current-byte- :bits-left ,-bits-left-))) (unwind-protect (progn ,@body) (finish-write ,bitstream))))) (defun test-bitstreams (file width integer) (with-open-file (output file :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede :if-does-not-exist :create) (with-output-bitstream (bitstream output) (write-bits integer width bitstream))) (with-open-file (input file :direction :input :element-type '(unsigned-byte 8)) (with-input-bitstream (bitstream input) (list (read-bits width bitstream t) integer)))) ;;; Utility (defun sufficient-bits (&rest numbers) "Return the number of bits necessary to represent the largest number in NUMBERS." (loop for number in numbers maximizing (1+ (integer-length number))))

1 1

[Small-cl-src] WITH*
by Marco Baringer 16 Jul '04

16 Jul '04

;;;; Alleviate deep nesting. Suggestions for a better name are welcome. ;;;; ;;;; An example will explain this far better than i can with words, so: ;;;; ;;;; (with* ;;;; (let ((*special* '())) (declare (special *special*))) ;;;; (dolist (a a-list)) ;;;; (with-slots (foo bar baz) a) ;;;; (multiple-value-bind (c d e) (process baz)) ;;;; (progn ;;;; body)) ;;;; ==> ;;;; (let ((*special* '())) ;;;; (declare (special *special*)) ;;;; (dolist (a a-list) ;;;; (with-slots (foo bar baz) ;;;; a ;;;; (multiple-value-bind (c d e) ;;;; (process baz) ;;;; body)))) (defmacro with* (&body body) (cond ((cddr body) (append (first body) `((with* ,@(cdr body))))) ((cdr body) `(,@(first body) ,(second body))) (body (first body)) (t nil))) -- -Marco Ring the bells that still can ring. Forget your perfect offering. There is a crack in everything. That's how the light gets in. -Leonard Cohen

1 0

[Small-cl-src] packet.lisp, version 2
by Luke Gorrie 12 Jul '04

12 Jul '04

;;; packet.lisp -- Decode TCP/IP packets (version 2) ;;; Written by Luke Gorrie <luke(a)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 ;;; ;;; Revision history: ;;; ;;; Version 2: Added support for encoding. ;;; Dropped alist support. Now always using structures. ;;; ;;; TODO: conditions, IPv4 options, TCP. ;;; ;;;# Introduction ;;; ;;; This is a program for encoding and decoding the packet headers of ;;; some TCP/IP family protocols. It converts between packets ;;; represented as octet-vectors and structures. ;;; ;;; This program is a library; it's not very useful in itself. ;;; ;;; Written for CMUCL 19A. I've used some non-portable features: ;;; `ext:collect', `slot-value' on structures, and PCL introspection. ;; Avoid calling defpackage is the package already exists. ;; Is this correct? It does avoid a lot of irritating warnings due to ;; the programmed exports at the end of the file. (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "PACKET") (defpackage :packet (:use :common-lisp) ;; Note: structures and their accessors are auto-exported down below. (:export #:decode #:encode #:buffer #:octet #:packet #:header)))) (in-package :packet) ;;;# Top-level interface ;;; ;;; The program has two main data types: buffers and packets. Buffers ;;; are octet-vectors for the encoded binary representations of ;;; packets. ;;; (deftype buffer () "A network packet represented as a vector of octets." '(array octet (*))) (deftype octet () "An unsigned 8-bit byte." '(unsigned-byte 8)) ;;; A packet is a list of header structures followed by zero or more ;;; buffers of raw data. This is the representation of a decoded ;;; network packet's headers and payload. Note that the individual ;;; header types are defined down below in the protocol-specific ;;; sections. ;;; (deftype packet () "A list of headers and buffers representing a network packet." 'cons) (deftype header () "A decoded protocol header." '(or ethernet-header arp-header ipv4-header udp-header)) ;;; The `decode' and `encode' functions convert between the buffer and ;;; packet representations. They are inverse operations when applied ;;; to well-formed inputs. ;;; (declaim (ftype (function (buffer) packet) decode) (ftype (function (packet) buffer) encode)) (defun decode (buffer) "Decode BUFFER as a packet." (decode-headers buffer)) (defun encode (packet) "Encode PACKET into a buffer." (encode-headers packet)) ;;;# I/O machinery ;;; ;;; All our I/O is based on treating a `buffer' (octet-vector) as a ;;; stream of bits. For decoding we "grab" quantities of bits from the ;;; buffer as needed, and for encoding we similarly "shove" bits into ;;; an output buffer. ;;;## Input "grabbing" (defvar *decode-buffer* nil "Buffer containing the packet currently being decoded.") (defvar *decode-position* nil "Current bit-position in *DECODE-BUFFER*.") (defmacro with-buffer-input (buffer &body body) "Execute BODY, grabbing input from the beginning of BUFFER." `(let ((*decode-buffer* ,buffer) (*decode-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 `*decode-buffer*' and advance ;;; `*decode-position*'. (defun grab-octets (num) "Grab a vector of NUM octets." (let ((start (bit-octet *decode-position*))) (incf *decode-position* (* num 8)) (subseq *decode-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 *decode-buffer* (bit-octet *decode-position*)) (setf *decode-position* (octet-bit (length *decode-buffer*))))) (defmacro dpb! (value bytespec place) "Deposit VALUE into BYTESPEC of PLACE." `(setf ,place (dpb ,value ,bytespec ,place))) ;;; 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 *decode-position* 8)))) (offset (rem (- 8 (rem (+ *decode-position* size) 8)) 8)) (value (ldb (byte size offset) (aref *decode-buffer* (bit-octet *decode-position* nil))))) (decf remaining size) (dpb! value (byte size remaining) accumulator) (incf *decode-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)) ;;;## Output "shoving" (defvar *encode-buffer* nil "Buffer (adjustable and with fill-pointer) for encoding data into.") (defvar *encode-position* nil "The encoding position in *ENCODE-BUFFER*.") (defvar *encode-bit-bucket* 0 "Accumulator for smaller-than-byte output.") (defvar *encode-bit-offset* 0 "The current accumulator bit-position.") (defmacro with-buffer-output (() &body body) `(let ((*encode-buffer* (make-array '(0) :element-type 'octet :adjustable t :fill-pointer 0)) (*encode-position* 0) (*encode-bit-bucket* 0) (*encode-bit-offset* 0)) ,@body (coerce *encode-buffer* 'buffer))) (defun encoding-position () (length *encode-buffer*)) (defmacro with-buffer-patch (position &body body) "Shove output at POSITION, overwriting any that was already there. Used within WITH-BUFFER-OUTPUT." `(let ((*encode-position* ,position)) ,@body)) ;;; "Shove" functions extend `*encode-buffer*' and advance ;;; `*encode-position*'. (defun shove-octet (octet) (unless (zerop *encode-bit-offset*) (error "Attempt to shove an octet at unaligned position.")) (cond ((= *encode-position* (length *encode-buffer*)) (vector-push-extend octet *encode-buffer*) (incf *encode-position*)) ((< *encode-position* (length *encode-buffer*)) (setf (aref *encode-buffer* *encode-position*) octet) (incf *encode-position*)) (t (error "Can't shove to position ~D with ~D-length buffer!" *encode-position* (length *encode-buffer*))))) (defun shove-ethernet-address (address) (shove-vector (ethernet-address.octets address))) (defun shove-ipv4-address (address) (shove-vector (ipv4-address.octets address))) (defun shove-vector (vector) (map nil #'shove-octet vector)) (defun shove-bits (value nbits) "Shove NBITS of VALUE." (cond ((zerop nbits)) ((< (+ *encode-bit-offset* nbits) 8) ;; We can fit NBITS into the accumulator without filling it. ;; Deposit VALUE into the most-significant accumulator bits ;; available. (let ((store-offset (- 8 nbits *encode-bit-offset*))) (dpb! value (byte nbits store-offset) *encode-bit-bucket*) (incf *encode-bit-offset* nbits))) (t ;; We have at least enough data to complete a byte. We ;; consume enough of VALUE's most-significant bits to fill ;; the accumulator, output a byte, then recurse on any ;; remainder. (let* ((take-bits (- 8 *encode-bit-offset*)) ;; The TAKE-BITS most-significant bits of VALUE. (take-value (ldb (byte take-bits (- nbits take-bits)) value)) (store-offset (- 8 take-bits *encode-bit-offset*)) (remaining (- nbits take-bits))) (dpb! take-value (byte take-bits store-offset) *encode-bit-bucket*) (setf *encode-bit-offset* 0) (shove-octet *encode-bit-bucket*) ;; Recurse with the remainder. (shove-bits value remaining))))) ;;;# Protocol implementations ;;; ;;; Each protocol defines a pair of GRAB and SHOVE functions for its ;;; headers. (defvar *resolve-protocols* t "When non-nil protocol numbers are resolved to symbolic names. Unrecognised numbers are left as numbers.") (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)))) (defun rlookup (key alist) "Lookup the value of KEY in CDR-position in ALIST, else return KEY." (lookup key alist :errorp nil :reversep t)) ;;;## 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))) ;;;### Decode and encode (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))) (defparameter *ethernet-protocol-names* '((#x0806 . :arp) (#x0800 . :ipv4)) "Mapping from ethernet protocol numbers to symbolic names.") (defun grab-ethernet-header () "Grab an ethernet header and call FUNCTION with each part." (let ((struct (make-ethernet-header))) (flet ((header (name value) (setf (slot-value struct name) value))) (header 'dest (grab-ethernet-address)) (header 'source (grab-ethernet-address)) (header 'protocol (ethernet-protocol-name (grab-bits 16)))) struct)) (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)) (defun shove-ethernet-header (header) (declare (type ethernet-header header)) (with-slots (dest source protocol) header (shove-ethernet-address dest) (shove-ethernet-address source) (shove-bits (rlookup protocol *ethernet-protocol-names*) 16)) (constantly nil)) ;;;## 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 grab-arp-header () "Grab an ARP header and call FUNCTION with each part." (let ((struct (make-arp-header))) (flet ((header (name value) (setf (slot-value struct 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))) struct)) (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)) (defun shove-arp-header (header) (declare (type arp-header header)) (with-slots (hardware-type protocol-type hardware-length protocol-length operation sender-ha sender-ip target-ha target-ip) header (shove-bits hardware-type 16) (shove-bits protocol-type 16) (shove-octet hardware-length) (shove-octet protocol-length) (shove-bits (rlookup operation *arp-operation-names*) 16) (shove-ethernet-address sender-ha) (shove-ipv4-address sender-ip) (shove-ethernet-address target-ha) (shove-ipv4-address target-ip)) (constantly nil)) ;;;## IPv4 ;;; ;;; The Internet Protocol is described in RFC791. ;;; ;;;### ipv4-address ;;; ;;; IP addresses also have a special read-syntax: `(a)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))) (defconstant ipv4-min-hlen 5 "The header length (in 32-bit words) of an IPv4 packet with no options.") (defun grab-ipv4-header () (let ((struct (make-ipv4-header)) (header-start-pos (bit-octet *decode-position*)) hlen checksum) (flet ((header (name value) (setf (slot-value struct name) value))) (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.")) (let* ((initial (- checksum)) (header-octets (* hlen 4)) (computed-checksum (checksum *decode-buffer* :position header-start-pos :length header-octets :initial initial))) (unless (eql checksum computed-checksum) (error "Bad checksum: Got ~D, computed ~D." checksum computed-checksum)))) struct)) (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)) (defconstant ipv4-no-options-hlen 5) (defun shove-ipv4-header (header) "Shove an IPv4 header. The length and checksum fields are computed automatically." (with-slots (version hlen tos total-len id flags fragment-offset ttl protocol checksum source dest) header (let (start total-len-pos checksum-pos) (setf start (encoding-position)) (shove-bits version 4) (shove-bits ipv4-no-options-hlen 4) (shove-bits tos 8) (setf total-len-pos (encoding-position)) (shove-bits 0 16) ; total-len (shove-bits id 16) (shove-bits flags 3) (shove-bits fragment-offset 13) (shove-bits ttl 8) (shove-bits (rlookup protocol ipv4-protocol-names) 8) ;; Remember where the checksum is: we have to come back and ;; patch it in. (setf checksum-pos (encoding-position)) (shove-bits 0 16) (shove-ipv4-address source) (shove-ipv4-address dest) (lambda () (with-buffer-patch total-len-pos (let ((total-len (- (length *encode-buffer*) start))) (shove-bits total-len 16))) (with-buffer-patch checksum-pos (shove-bits (checksum *encode-buffer* :position start :length (* ipv4-no-options-hlen 4)) 16)))))) ;;;## 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)))) (defun grab-udp-header (&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." (let ((struct (make-udp-header)) (header-start (bit-octet *decode-position*)) checksum length) (flet ((header (name value) (setf (slot-value struct name) value))) (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))) (when (and src-ip dest-ip) (unless (zerop checksum) ; checksum is optional (let* ((init (- (udp-pseudo-header-checksum-acc src-ip dest-ip length) checksum)) (computed-checksum (checksum *decode-buffer* :position header-start :length length :initial init))) (unless (eql checksum computed-checksum) (error "Bad checksum: Got ~D, computed ~D." checksum computed-checksum)))))) struct)) (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)) (defun shove-udp-header (header src-ip dest-ip) "Shove a UDP header. SRC-IP and DEST-IP are from the outer IPv4 header." (with-slots (src-port dest-port checksum) header (let ((start-pos (encoding-position)) length-pos checksum-pos) (shove-bits src-port 16) (shove-bits dest-port 16) (setf length-pos (encoding-position)) (shove-bits 0 16) (setf checksum-pos (encoding-position)) (shove-bits 0 16) (lambda () (let ((length (- (length *encode-buffer*) start-pos))) (with-buffer-patch length-pos (shove-bits length 16)) (let ((csum (checksum *encode-buffer* :position start-pos :initial (udp-pseudo-header-checksum-acc src-ip dest-ip length)))) (with-buffer-patch checksum-pos (shove-bits csum 16)))))))) ;;;# Checksum computation ;;; ;;; The TCP/IP protocols use 16-bit ones-complement checksums. See ;;; RFC1071 for details. (defun checksum (buffer &key (position 0) (length (- (length buffer) position)) (initial 0) (finish t)) "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))) ((> msb-pos last-pos)) (let ((msb (aref buffer msb-pos)) (lsb (if (> lsb-pos last-pos) 0 (aref buffer lsb-pos)))) (incf acc (dpb msb (byte 8 8) lsb)))) (if finish (finish-checksum acc) acc))) (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)))) (defun checksum-acc-ipv4-address (address) "Return the partial checksum accumulated from an IPv4 address." (checksum (ipv4-address.octets address) :finish nil)) ;;;# Decoding driver (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 decode-headers (buffer) "Return a list of decoded headers from BUFFER" (with-buffer-input buffer (let* ((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." (if (member (type-of header) '(ethernet-header ipv4-header)) (let ((*previous-header* header) (inner-protocol (slot-value 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." (case protocol (:ethernet (grab-ethernet-header)) (:arp (grab-arp-header)) (:ipv4 (grab-ipv4-header)) (:udp (let ((src-ip (slot-value *previous-header* 'source)) (dest-ip (slot-value *previous-header* 'dest))) (grab-udp-header src-ip dest-ip))))) ;;;# Encoding driver ;;; ;;; To encode a packet we "shove" each element into a vector and then ;;; apply the "touchup functions". (defun encode-headers (headers) (let (src-ip dest-ip) (flet ((shove-element (e) ;; Shove E into the encoding vector and return a touchup. (etypecase e (buffer (shove-vector e) (constantly nil)) (ethernet-header (shove-ethernet-header e)) (arp-header (shove-arp-header e)) (ipv4-header (setf src-ip (ipv4-header.source e)) (setf dest-ip (ipv4-header.dest e)) (shove-ipv4-header e)) (udp-header (assert (and src-ip dest-ip)) (shove-udp-header e src-ip dest-ip))))) (with-buffer-output () (let ((touchups '())) (dolist (e headers) (push (shove-element e) touchups)) (mapc #'funcall touchups)))))) ;;;# Sample packets (defparameter *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.") (defparameter *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 () (decode-test) (encode-test) 'ok) (defun decode-test () "Test that the sample packets are decoded correctly." (let* ((arp-headers (decode *arp-packet*)) (udp-headers (decode *udp-packet*))) (check-headers arp-headers '((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))))) (check-headers udp-headers `((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))) (UDP-HEADER ((SRC-PORT . 32885) (DEST-PORT . 111) (LENGTH . 104) (CHECKSUM . 1486))) ,(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))))) (defun check-headers (headers specs) "Check that HEADERS agrees element-wise with SPECS. SPECS is a list of specifications of what a header should contain." (flet ((check (header spec) ;; Raise an error if HEADER doesn't match SPEC. (loop for (slot . value) in (second spec) do (unless (equalp (slot-value header slot) value) (error "Slot ~A: Expected ~A, got ~A." slot value (slot-value header slot))) always t))) (unless (and (null headers) (null specs)) (let ((header (first headers)) (spec (first specs))) (if (and (typep header 'buffer) (typep spec 'buffer)) (unless (equalp header spec) (error "Mismatch in binary parts.")) (progn (unless (eq (type-of header) (first spec)) (error "Header type mismatch: ~A ~A" (type-of header) (first spec))) (check header spec) (check-headers (rest headers) (rest specs)))))))) (defun encode-test () "Check that (encode (decode PACKET)) <=> identity." (assert (and (equalp *udp-packet* (encode (decode *udp-packet*))) (equalp *arp-packet* (encode (decode *arp-packet*)))))) (defun bench (n) "Show how long it takes to decode and re-encode 10^N UDP packets." (time (dotimes (i (expt 10 n)) (encode (decode *udp-packet*))))) ;;;# Exporting structures ;;; ;;; My pet hate is explicitly enumerating all the accessors for ;;; structures in export declarations. Instead we do a little ;;; introspection to enumerate them automatically, and jump through ;;; some hoops with `defpackage' (above) to avoid warnings. (eval-when (:compile-toplevel :load-toplevel) (defun structure-exports () "The list of defstruct-defined symbols that we want to export." (apply #'append (mapcar #'structure-symbol-names '(ethernet-header ethernet-address arp-header ipv4-header ipv4-address udp-header)))) (defun structure-symbol-names (name) "Return all the interesting symbols generated by DEFSTRUCT for NAME. Assumes a FOO type name, MAKE-FOO constructor, and FOO-P predicate to avoid excessively low-level introspection." (list* name (find-symbol (format nil "~A-P" name)) (find-symbol (format nil "MAKE-~A" name)) (structure-accessors name))) (defun structure-accessors (name) (mapcar #'pcl::slot-definition-defstruct-accessor-symbol (pcl:class-direct-slots (find-class name)))) (export (structure-exports)))

1 0

[Small-cl-src] Small, occasionally handy piece of code
by Ingvar 09 Jul '04

09 Jul '04

;;; Haven't we all felt the need of generating combinations from a collection ;;; and calling a function for every combination? ;;; ;;; It's about as easy as this: ;;; <list> is the initial set ;;; <num> is the number of elements in the resulting combination ;;; <func> is the callback function (defun call-with-combination (list num func &optional acc) (declare (list list acc) (fixnum num) (function func)) (if (zerop num) (apply func acc) (loop for elt in list do (call-with-combination (remove elt list) (1- num) func (cons elt acc)))))

2 2

[Small-cl-src] Useless piece of code, with Important Information in comments
by Ingvar 09 Jul '04

09 Jul '04

;;; No More Mr Nice Listadmin... ;;; Remember, small-cl-src is "source code only" and "plain text". ;;; ALL comments on code SHOULD be sent to small-cl-src-discuss(a)hexapodia.net ;;; Attachments MUST NOT be used when mailing small-cl-src ;;; In theory, in a unix environment, with an mh-style mailfile ;;; the following should result in a loadable lisp file (when called with the ;;; file name of the mh-style mail file and a suitable output stream): (defun extract-small-cl-source (filename &optional (outstream t)) (let ((extract nil)) (with-open-file (infile filename) (do ((line (read-line infile nil infile) (read-line infile nil infile))) ((or (eq line infile) (string= line "_______________________________________________") (string= line "-- ")) nil) (setf extract (or extract (string= line ""))) (when extract (format outstream "~a~%" line))))))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

small-cl-src July 2004