Apparently even nonblocking reads are blocking in a way(?!) and we will get multiple packets off the iface.

The actual packet data is preceded by a "struct bpf_hdr" header we need to skip.  Because of that, passing a raw buffer is not going to be very useful, so bpf-read-packet! can be removed from the API.

1 files changed, 67 insertions, 8 deletions

diff --git a/bpf-interface.scm b/bpf-interface.scm
index 0277140..b80a086 100644
--- a/bpf-interface.scm
+++ b/bpf-interface.scm
@@ -9,11 +9,11 @@
   (bpf-open bpf-close bpf? bpf-buffer-length bpf-flush!
             bpf-interface bpf-interface-set! bpf-stats
             bpf-datalink-type bpf-datalink-type-set! bpf-list-datalink-types
-            bpf-filter-set!)
+            bpf-filter-set! bpf-read-packet)
 
 (import chicken scheme foreign)
 
-(use posix lolevel srfi-1 srfi-4 bitstring)
+(use posix lolevel srfi-1 srfi-4 bitstring bpf-assembler)
 
 (foreign-declare "#include <errno.h>")
 (foreign-declare "#include <string.h>")
@@ -57,7 +57,9 @@
 
 ;;;;;;;;;;;
 
-(define-record bpf fd)
+;; tmp-buffer is a stupid workaround for the fact that buffer length must
+;; match the read size, even in nonblocking mode.
+(define-record bpf fd tmp-buffer tmp-buffer-offset tmp-buffer-max-offset)
 
 (define-record-printer (bpf obj out)
   (if (bpf-fd obj)
@@ -85,14 +87,15 @@
                      (make-property-condition 'bpf)
                      (make-property-condition 'i/o)
                      (make-property-condition 'file))))
-          (let* ((mode (bitwise-ior open/read open/write open/nonblock))
+          (let* ((mode (bitwise-ior open/rdwr open/nonblock))
                  (fd (condition-case (file-open fn mode)
                        (e (exn i/o file) (lp (fx+ i 1) fn e))))
-                 (bpf (make-bpf fd)))
+                 (bpf (make-bpf fd #f #f #f)))
             (set-finalizer! bpf bpf-close)
             ;; Length _must_ be set before interface is assigned
-            (when buffer-length
-              (bpf-buffer-length-set! bpf buffer-length))
+            (if buffer-length
+                (bpf-buffer-length-set! bpf buffer-length)
+                (bpf-tmp-buffer-set! bpf (make-blob (bpf-buffer-length bpf))))
             (bpf-interface-set! bpf interface)
             ;; Rather pointless to expose this as a "setter" procedure(?)
             (when promiscuous
@@ -115,6 +118,10 @@
 (define (bpf-buffer-length-set! bpf requested-length)
   (let-location ((new-length int requested-length))
     (ioctl bpf BIOCSBLEN new-length)
+    ;; TODO: Should we copy the bits of the old buffer that fit in the new?
+    (bpf-tmp-buffer-offset-set! bpf #f)
+    (bpf-tmp-buffer-max-offset-set! bpf #f)
+    (bpf-tmp-buffer-set! bpf (make-blob new-length))
     new-length))
 
 (define interface-name-maximum-length (foreign-value "IF_NAMESIZE" int))
@@ -221,7 +228,9 @@
 (define (bpf-filter-set! bpf filter)
   (check-version! bpf)
   (let ((prog (make-blob (foreign-value "sizeof(struct bpf_program)" int)))
-        (insns (cond ((bitstring? filter) (bitstring->blob filter))
+        (insns (cond ((pair? filter)
+                      (bitstring->blob (exprs->bpf-bytecode filter)))
+                     ((bitstring? filter) (bitstring->blob filter))
                      ((or (blob? filter) (string? filter)) filter)
                      ((u8vector? filter) (u8vector->blob/shared filter))
                      (else (error "Unsupported filter data type" filter)))))
@@ -232,4 +241,54 @@
     (ioctl bpf BIOCSETF prog)
     (void)))
 
+(define (extract-next-packet! bpf)
+  (let* ((tmp-buf (bpf-tmp-buffer bpf))
+         (tmp-offset (bpf-tmp-buffer-offset bpf)))
+    (let-location ((caplen int)
+                   (offset-add int))
+      ;; Calculate capture size and offset of the next packet's start
+      ((foreign-lambda* void (((c-pointer "struct bpf_hdr") bh)
+                              ((c-pointer int) caplen) ((c-pointer int) offset))
+         "*caplen = bh->bh_caplen;"
+         "*offset = BPF_WORDALIGN(bh->bh_hdrlen + bh->bh_caplen);")
+       (make-locative tmp-buf tmp-offset)
+       (location caplen) (location offset-add))
+      (let* ((tmp-max-offset (bpf-tmp-buffer-max-offset bpf))
+             (buffer (make-blob caplen)))
+        ((foreign-lambda* void (((c-pointer "struct bpf_hdr") bh)
+                                (scheme-pointer buf))
+           "C_memcpy(buf, (void *)bh+bh->bh_hdrlen, bh->bh_caplen);")
+         (make-locative tmp-buf tmp-offset) buffer)
+        ;; Advance, or reset if we've reached the end
+        (bpf-tmp-buffer-offset-set!
+         bpf (and (not (>= (+ tmp-offset offset-add) tmp-max-offset))
+                  (+ tmp-offset offset-add)))
+        buffer))))
+
+(define (bpf-read-packet bpf)
+  (let* ((fd (bpf-fd bpf))
+         (tmp-buf (bpf-tmp-buffer bpf)))
+    (unless (bpf-tmp-buffer-offset bpf) ; Only read if no data in buffer
+      (let lp ()
+        (let-location ((err int) (n int))
+          ((foreign-lambda* void ((int fd) (scheme-pointer p) (int len)
+                                  ((c-pointer int) err) ((c-pointer int) n))
+             "*n = read(fd, p, len);"
+             "*err = errno;")
+           fd tmp-buf (##sys#size tmp-buf) (location err) (location n))
+          ;; We use ##sys# here to avoid having to load srfi-18
+          (cond
+           ((or (fx= -1 n) (fx= 0 n)) ; 0 is returned on OpenBSD for EAGAIN
+            (if (or (fx= 0 n) (fx= err (foreign-value "EAGAIN" int)))
+                (begin
+                  (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
+                  (##sys#thread-yield!)
+                  (lp))
+                (error (string-append "Cannot read packet - "
+                                      (error-string err)) bpf)))
+           (else
+            (bpf-tmp-buffer-offset-set! bpf 0)
+            (bpf-tmp-buffer-max-offset-set! bpf n))))))
+    (extract-next-packet! bpf)))
+
 )