51474 xristos (defclass pcap () ((pcap_t :initform nil :documentation "Foreign pointer to pcap structure.") (callback :initform nil :documentation "Foreign callback for packet handler.") (interface :initarg :interface :reader pcap-interface :initform nil :documentation "Interface to capture packets from.") (snaplen :initarg :snaplen :reader pcap-snaplen :initform 1600 ; Same as tcpdump, 68 enough for headers :documentation "How many bytes to capture per packet received.") (promisc :initarg :promisc :reader pcap-promisc :initform nil :documentation "True if capturing in promiscuous mode.") (timeout :initarg :timeout :reader pcap-timeout :initform 1 :documentation "Read timeout in milliseconds. 0 will wait forever.") (datalink :reader pcap-datalink :initform nil :documentation "Datalink protocol for this device.") (buffer :reader pcap-buffer :initform nil :documentation "Packet buffer to hold captured packets.") (handler :initform nil :documentation "Lisp packet handler for capture. Called by callback.") (live :reader pcap-live :initform nil :documentation "Packet capture object is live."))) (defmethod initialize-instance :after ((cap pcap) &key) (with-slots (pcap_t callback interface snaplen promisc timeout datalink buffer handler live) cap (with-error-buffer (eb) ;; No interface given, call lookupdev to get one (when (null interface) (let ((res (%pcap-lookupdev eb))) (when (null res) (error 'network-interface-error :text (error-buffer-to-lisp eb))) (setf interface res))) (clear-error-buffer eb) ;; Open interface for capture (let* ((res (%pcap-open-live interface snaplen promisc timeout eb)) (ebtext (error-buffer-to-lisp eb))) (when (null-pointer-p res) (error 'network-interface-error :text ebtext)) (setf pcap_t res) ;; Supported datalink test (let ((dlink (rassoc (%pcap-datalink pcap_t) *supported-datalinks*))) (if (not dlink) (progn (%pcap-close pcap_t) (error 'network-interface-error :text "Unsupported datalink protocol")) (setf datalink (car dlink)))) (when (not (= 0 (length ebtext))) (warn ebtext)) (setf buffer (make-array snaplen :element-type '(unsigned-byte 8))) (setf callback (defcallback pcap-handler :void ((user :pointer) (pkthdr :pointer) (bytes :pointer)) (with-foreign-slots ((caplen len) pkthdr pcap_pkthdr) ;; Copy packet data from C to lisp #+:sbcl (let ((dst (sb-sys:vector-sap buffer))) (%memcpy dst bytes caplen)) #-:sbcl (loop for i from 0 to (- caplen 1) do (setf (aref buffer i) (mem-aref bytes :uint8 i))) ;; Call lisp packet handler (funcall handler caplen len)))) (setf live t))))) 3405181903 #lispcafe