;;;
;;; Interface to the /dev/bpf[N] devices (ioctls, opening/closing etc)
;;;
;;; Copyright (c) 2013 by Peter Bex, see file COPYING.BSD
;;;
;;; TODO: Think about FreeBSD/OpenBSD extensions like LOCK, DIRFILT.
;;;       OS X seems to support only the smallest common denominator.
(module bpf-interface
  (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-read-packet)

(import chicken scheme foreign)

(use posix lolevel srfi-1 srfi-4 bitstring bpf-assembler)

(foreign-declare "#include <errno.h>")
(foreign-declare "#include <string.h>")

(foreign-declare "#include <sys/types.h>")
(foreign-declare "#include <sys/time.h>")
(foreign-declare "#include <sys/ioctl.h>")
(foreign-declare "#include <net/bpf.h>")
;; For BIOCGETIF/BIOCSETIF
(foreign-declare "#include <net/if.h>")

(define error-string (foreign-lambda c-string "strerror" int))

;; From the IOCTL egg, with some tweaks for brevity and convenience
(define ioctl0
  (foreign-lambda* int (((c-pointer int) err) (int fd) (unsigned-long req))
    "int res = ioctl(fd, req);"
    "*err = errno;"
    "return(res);"))

(define ioctl1
  (foreign-lambda* int (((c-pointer int) err) (int fd)
                        (unsigned-long req) (c-pointer val1))
    "int res = ioctl(fd, req, val1);"
    "*err = errno;"
    "return(res);"))

(define-syntax ioctl
  (ir-macro-transformer
   (lambda (e i c)
     (let ((fd `(bpf-fd ,(cadr e)))     ; Always a bpf object
           (request `(foreign-value ,(->string (strip-syntax (caddr e))) int))
           (arg (and (pair? (cdddr e)) `(location ,(cadddr e)))))
       `(let-location ((err int))
          (let ((res ,(if arg
                          `(ioctl1 (location err) ,fd ,request ,arg)
                          `(ioctl0 (location err) ,fd ,request))))
            (if (= res -1)
                (error (error-string err))
                res)))))))

;;;;;;;;;;;

;; 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)
      (fprintf out "#<bpf on interface: ~S>" (bpf-interface obj))
      (display "#<bpf (closed)>" out)))

;; Promiscuous mode is not guaranteed to be off even if the flag is #f
(define (bpf-open interface #!key buffer-length promiscuous)
  (let lp ((i -1)
           (prev-fn #f)
           (prev-error #f))
    ;; Try /dev/bpf first, before enumerating all of the /dev/bpfN options.
    ;; If all fail, show the error of the last file we tried, as soon as we
    ;; can't find any existing bpf files anymore.
    ;; This can be improved if Chicken allowed us to distinguish between
    ;; "nonexistent file"-type errors and other errors.
    (let ((fn (string-append "/dev/bpf" (if (fx= i -1) "" (number->string i)))))
      (if (and prev-error (not (file-exists? fn)))
          (let* ((om (get-condition-property prev-error 'exn 'message))
                 (msg (string-append
                       "Unable to open bpf device " prev-fn ": " om)))
            (signal (make-composite-condition
                     (make-property-condition
                      'exn 'location 'bpf-open 'message msg)
                     (make-property-condition 'bpf)
                     (make-property-condition 'i/o)
                     (make-property-condition 'file))))
          (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 #f #f #f)))
            (set-finalizer! bpf bpf-close)
            ;; Length _must_ be set before interface is assigned
            (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
              (ioctl bpf BIOCPROMISC))
            bpf)))))

(define (bpf-close bpf)
  (and-let* ((fd (bpf-fd bpf)))
    (file-close fd)
    (bpf-fd-set! bpf #f))
  (void))

(define (bpf-flush! bpf)
  (ioctl bpf BIOCFLUSH))

;; Returns the *actual* size that was set, the requested size is too big
;; Remember, this can only be done *before* setting the interface.
;; Oddly enough, the interface can be switched afterwards, so there's
;; no way to set a new interface *and* buffer-length...
(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))

(define (bpf-interface-set! bpf interface)
  (let ((ifreq (make-blob (foreign-value "sizeof(struct ifreq)" int)))
        (len (string-length interface)))
    (when (>= len interface-name-maximum-length)
      (error (string-append "Interface name exceeds maximum length of "
                            (number->string interface-name-maximum-length))
             interface))
    ((foreign-lambda* void ((scheme-pointer i) (scheme-pointer s) (int len))
       "char *ifname = ((struct ifreq *)i)->ifr_name;"
       "strncpy(ifname, s, len);"
       "ifname[len] = '\\0';") ifreq interface len)
    (ioctl bpf BIOCSETIF ifreq)
    (void)))

(define (bpf-interface bpf)
  (let ((ifreq (make-blob (foreign-value "sizeof(struct ifreq)" int))))
    (ioctl bpf BIOCGETIF ifreq)
    ((foreign-lambda* c-string ((scheme-pointer i))
       "C_return(((struct ifreq *)i)->ifr_name);") ifreq)))

(define (bpf-buffer-length bpf)
  (let-location ((length unsigned-int))
    (ioctl bpf BIOCGBLEN length)
    length))

;; These are a bit problematic: there is a shitload of known types.
;; Maybe we should automatically convert to a symbol, but that
;; requires coding all of the types in here.  OTOH, that's
;; more-or-less what C is doing with its #defines.
(define (bpf-datalink-type bpf)
  (let-location ((type unsigned-int))
    (ioctl bpf BIOCGDLT type)
    type))

(define (bpf-datalink-type-set! bpf type)
  (let-location ((type unsigned-int type))
    (ioctl bpf BIOCSDLT type)
    (void)))

(define (bpf-list-datalink-types bpf)
  ;; First, get the number of types (required slot length)
  (let ((in (make-blob (foreign-value "sizeof(struct bpf_dltlist)" int))))
    ((foreign-lambda* void (((c-pointer "struct bpf_dltlist") p))
       "p->bfl_list = NULL;") (location in))
    (ioctl bpf BIOCGDLTLIST in)
    (let* ((length ((foreign-lambda* unsigned-int
                        (((c-pointer "struct bpf_dltlist") p))
                      "C_return(p->bfl_len);") (location in)))
           ;; Now, get that many types
           (types (make-blob (* (foreign-value "sizeof(u_int)" int) length))))
      ((foreign-lambda* void (((c-pointer "struct bpf_dltlist") p)
                              ((c-pointer "u_int") list))
         "p->bfl_list = list;") (location in) (location types))
      (ioctl bpf BIOCGDLTLIST in)
      (list-tabulate
       length
       (lambda (i)
         ((foreign-lambda* unsigned-int (((c-pointer "u_int") p) (int i))
            "C_return(p[i]);") (location types) i))))))

(define (bpf-stats bpf)
  (let ((st (make-blob (foreign-value "sizeof(struct bpf_stat)" int))))
    (ioctl bpf BIOCGSTATS st)
    (let ((result '()))
      (let-syntax ((add-stat!
                    (syntax-rules ()
                      ((_ ?scheme-name ?c-name)
                       (set! result
                         (alist-cons '?scheme-name
                                     ((foreign-lambda* unsigned-integer64
                                          (((c-pointer "struct bpf_stat") st))
                                        "C_return((uint64_t)st->" ?c-name ");")
                                      (location st))
                                     result))))))
        (add-stat! received "bs_recv")
        (add-stat! dropped "bs_drop")
        (cond-expand (netbsd (add-stat! captured "bs_capt")))
        result))))

;; Maybe success should be cached inside the bpf object?
(define (check-version! bpf)
  (let ((expected-major (foreign-value "BPF_MAJOR_VERSION" int))
        (expected-minor (foreign-value "BPF_MINOR_VERSION" int))
        (v (make-blob (foreign-value "sizeof(struct bpf_version)" int))))
    (ioctl bpf BIOCVERSION v)
    (let-location ((major int) (minor int))
      ((foreign-lambda* void (((c-pointer "struct bpf_version") v)
                              ((c-pointer int) major) ((c-pointer int) minor))
         "*major = v->bv_major;"
         "*minor = v->bv_minor;")
       (location v) (location major) (location minor))
      ;; "Version numbers are compatible if the major numbers match and
      ;; the application minor is less than or equal to the kernel minor."
      (unless (and (= major expected-major)
                   (<= expected-minor minor))
        (error "BPF filter language version mismatch!"
               (cons major minor)
               (cons expected-major expected-minor))))))

(define (bpf-filter-set! bpf filter)
  (check-version! bpf)
  (let ((prog (make-blob (foreign-value "sizeof(struct bpf_program)" int)))
        (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)))))
    ((foreign-lambda* void (((c-pointer "struct bpf_program") p)
                            (scheme-pointer i) (unsigned-int len))
       "p->bf_len = len;"
       "p->bf_insns = i;") (location prog) insns (fx/ (##sys#size insns) 8))
    (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)))

)