Fix a few problems with the jump instructions (forgot to add #x05 to all of the conditional ones, too), make uint? and label? also recognise zero as valid and fix error expression of disassembler.

Implement back-and-forth transcoding of tcpdump's "decimal encoding" output of compiled packet matching instructions (using -ddd).
Fixed a few bugs I ran into with bitstring, so depend on the version to be released next (this code triggers error situations in the current version)

3 files changed, 147 insertions, 20 deletions

diff --git a/bpf-assembler.scm b/bpf-assembler.scm
index 07e7f39..9614fac 100644
--- a/bpf-assembler.scm
+++ b/bpf-assembler.scm
@@ -4,14 +4,15 @@
 ;;; Copyright (c) 2013 by Peter Bex, see file COPYING.BSD
 ;;;
 (module bpf-assembler
-        (exprs->bpf-bytecode bpf-bytecode->exprs)
+        (exprs->bpf-bytecode bpf-bytecode->exprs
+         read-decimal-bpf-bytecode write-decimal-bpf-bytecode)
 
 (import chicken scheme)
-(use srfi-1 bitstring matchable)
+(use extras srfi-1 bitstring matchable)
 
-(define (uint? x) (and (integer? x) (positive? x)))
-;; Is a jump of zero allowed?  It shouldn't be!
-(define (label? x) (and (integer? x) (< 0 x 256)))
+(define (uint? x) (and (integer? x) (or (zero? x) (positive? x))))
+;; Labels are jump offset from *next* instruction (a little surprising perhaps)
+(define (label? x) (and (integer? x) (<= 0 x 256)))
 
 ;; Basic idea stolen from sixtyfive-oh-two.  Thanks, Felix! ;)
 (begin-for-syntax
@@ -67,7 +68,7 @@
  (defaddrmode conditional-jump-index-register #x08
    (('x (and jt (? label?)) (and jf (? label?))) => jt jf 0) ; zero?
    (jt jf _ => (x ,jt ,jf)))
-
+ 
  (define-syntax defop
    (syntax-rules ()
      ((_ ?mnemonic ?opcode ?addrmode0 ...)
@@ -84,10 +85,10 @@
  (defop st   #x02 memory-ref)
  (defop stx  #x03 memory-ref)
  (defop jmp  #x05 immediate)            ; aka JA
- (defop jeq  #x10 conditional-jump-immediate conditional-jump-index-register)
- (defop jgt  #x20 conditional-jump-immediate conditional-jump-index-register)
- (defop jge  #x30 conditional-jump-immediate conditional-jump-index-register)
- (defop jset #x40 conditional-jump-immediate conditional-jump-index-register)
+ (defop jeq  #x15 conditional-jump-immediate conditional-jump-index-register)
+ (defop jgt  #x25 conditional-jump-immediate conditional-jump-index-register)
+ (defop jge  #x35 conditional-jump-immediate conditional-jump-index-register)
+ (defop jset #x45 conditional-jump-immediate conditional-jump-index-register)
  (defop add  #x04 index-register immediate)
  (defop sub  #x14 index-register immediate)
  (defop mul  #x24 index-register immediate)
@@ -159,7 +160,7 @@
                           ,(list 'quasiquote (cons mnemonic disasm-expr)))))
                     modes)))
                 (reverse opcodes))
-         (else "Unrecognised instruction" insn))))))
+         (else (error "Unrecognised instruction" (bitstring->list insn 8))))))))
 
 (define (bpf-bytecode->exprs bytecode)
   (let lp ((bytecode bytecode)
@@ -169,4 +170,47 @@
                (lp rest (cons (disassemble-instruction insn) exprs)))
               (() (reverse exprs)))))
 
+(define (read-number port)
+  (read-token char-whitespace? port)  ; First, skip any whitespace
+  (let* ((token (read-token (lambda (x) (not (char-whitespace? x))) port))
+         (num (string->number token)))
+    (unless (and num (integer? num) (or (zero? num) (positive? num)))
+      (receive pos (port-position port)
+        (error "Expected to read a positive integer" port pos token num)))
+    num))
+
+;; For reading bytecode from tcpdump's -dd output
+(define (read-decimal-bpf-bytecode
+         #!optional (port (current-input-port)) (count #f))
+  (let lp ((pos 0)
+           (count? (or (eq? count #f)
+                       (and (integer? count) (positive? count))))
+           (count (or count (read-number port)))
+           (bytecode (bitconstruct)))
+    (cond ((and count? (>= pos count)) bytecode)
+          ((eof-object? (peek-char port))
+           (if (not count?)
+               bytecode
+               (error "Expected more instructions due to count" count)))
+          (else
+           (let* ((op (read-number port))
+                  (jt (read-number port))
+                  (jf (read-number port))
+                  (k (read-number port)))
+             (lp (fx+ pos 1) count? count
+                 (bitstring-append
+                  bytecode (bitconstruct (op 16 host) (jt) (jf) (k 32 host)))))))))
+
+(define (write-decimal-bpf-bytecode
+         code #!optional (port (current-output-port)) raw-code?)
+  (let ((code (bitstring-of-any code)))
+    (unless raw-code?
+      (fprintf port "~A\n" (quotient (bitstring-length code) 64)))
+    (let lp ((code code))
+      (bitmatch code
+                (((op 16 host) (jt) (jf) (k 32 host) (rest bitstring))
+                 (fprintf port "~A ~A ~A ~A\n" op jt jf k)
+                 (lp rest))
+                (() (void))))))
+
 )
diff --git a/bpf.meta b/bpf.meta
index a5ffaba..9be37e7 100644
--- a/bpf.meta
+++ b/bpf.meta
@@ -4,5 +4,5 @@
  (author "Peter Bex")
  (category net)
  (license "BSD")
- (depends bitstring matchable)
+ (depends (bitstring "0.6") matchable)
  (test-depends test))
diff --git a/tests/run.scm b/tests/run.scm
index fc7c3d6..b0e8e46 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,4 +1,4 @@
-(use test matchable)
+(use test matchable bitstring srfi-13)
 
 (include "../bpf-assembler.scm")
 
@@ -21,12 +21,13 @@
               ;; store accumulator/index register
               (st (mem 1)) (stx (mem 1))
               ;; jump unconditionally (sometimes called JA instead of JMP)
-              (jmp 1)
+              (jmp 1) (jmp 0)
               ;; Jump conditionally on comparison of acc w/ immediate or idx
-              (jeq 1 2 3) (jeq x 2 3) (jgt 1 2 3) (jgt x 2 3)
-              (jge 1 2 3) (jge x 2 3)
+              (jeq 0 2 3) (jeq 1 2 3) (jeq x 2 3)
+              (jgt 0 2 3) (jgt 1 2 3) (jgt x 2 3)
+              (jge 0 2 3) (jge 1 2 3) (jge x 2 3)
               ;; Jump if bit # from immediate/index register is set in acc
-              (jset 1 2 3) (jset x 2 3)
+              (jset 0 2 3) (jset 1 2 3) (jset x 2 3)
               ;; ALU instructions: operates on acc w/ immediate or index
               (add 1) (add x) (sub 1) (sub x) (mul 1) (mul x) (div 1) (div x)
               (or 1) (or x) (and 1) (and x) (lsh 1) (lsh x) (rsh 1) (rsh x)
@@ -63,9 +64,9 @@
                (stx 1) (stx len) (stx a) (stx x) (stx (mem x 1))
                (stx (pkt 1)) (stx (pkt 4* 1)))
 
-              ("bogus jump types"
-               (jmp x) (jmp a) (jmp (mem 1)) (jmp len))
-              
+              ("bogus jump types and negative labels"
+               (jmp x) (jmp a) (jmp (mem 1)) (jmp len) (jmp -1) (jeq -1 1 2))
+
               ("unconditional jumps can't work conditionally"
                (jmp 1 2 3) (jmp x 2 3))
 
@@ -87,6 +88,88 @@
               ("returning non-immediate, non-register values"
                (ret (mem 1)) (ret (pkt 1)) (ret (pkt x 1)) (ret (pkt 4* 1))))))
 
+(test-group "multi-instruction assembly/disassembly invariance"
+  (for-each (match-lambda
+              ((description . exprs)
+               (test description
+                     exprs
+                     (bpf-bytecode->exprs (exprs->bpf-bytecode exprs)))))
+            `(("simple load and return" (ld 1234) (ret 10))
+
+              ("src localhost program"
+               (ldh (pkt 12))
+               (jeq #x0800 0 2)
+               (ld  (pkt 26))
+               (jeq #x7f000001 4 5)
+               (jeq #x0806 1 0)
+               (jeq #x8035 0 3)
+               (ld  (pkt 28))
+               (jeq #x7f000001 0 1)
+               (ret 65535)
+               (ret 0)))))
+
+(test-group "decimal bytecode reader"
+  (test "src localhost"
+        `((ldh (pkt 12))
+          (jeq #x0800 0 2)
+          (ld  (pkt 26))
+          (jeq #x7f000001 4 5)
+          (jeq #x0806 1 0)
+          (jeq #x8035 0 3)
+          (ld  (pkt 28))
+          (jeq #x7f000001 0 1)
+          (ret 65535)
+          (ret 0))
+        ;; String generated w/ tcpdump -ddd src localhost
+        (bpf-bytecode->exprs
+         (with-input-from-string
+             (string-join
+              `("10"
+                "40 0 0 12"
+                "21 0 2 2048"
+                "32 0 0 26"
+                "21 4 5 2130706433"
+                "21 1 0 2054"
+                "21 0 3 32821"
+                "32 0 0 28"
+                "21 0 1 2130706433"
+                "6 0 0 65535"
+                "6 0 0 0")
+              "\n" 'suffix)
+           (lambda () (read-decimal-bpf-bytecode))))))
+
+(test-group "decimal bytecode writer"
+  (test "src localhost"
+        ;; String generated w/ tcpdump -ddd src localhost
+        (string-join
+         `("10"
+           "40 0 0 12"
+           "21 0 2 2048"
+           "32 0 0 26"
+           "21 4 5 2130706433"
+           "21 1 0 2054"
+           "21 0 3 32821"
+           "32 0 0 28"
+           "21 0 1 2130706433"
+           "6 0 0 65535"
+           "6 0 0 0")
+         "\n" 'suffix)
+        (with-output-to-string
+          (lambda ()
+            (write-decimal-bpf-bytecode
+             (exprs->bpf-bytecode
+              `((ldh (pkt 12))
+                (jeq #x0800 0 2)
+                (ld  (pkt 26))
+                (jeq #x7f000001 4 5)
+                (jeq #x0806 1 0)
+                (jeq #x8035 0 3)
+                (ld  (pkt 28))
+                (jeq #x7f000001 0 1)
+                (ret 65535)
+                (ret 0))))))
+))
+
 (test-end "BPF assembler")
 
 (test-exit)