summaryrefslogtreecommitdiff
path: root/bpf-interface.scm
blob: a76228fde59b5c01c3532cbbe893394ffaa38171 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
;;;
;;; 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.
;;;       also NetBSD's "number of accepted packets" in GSTATS.
;;;       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-datalink-type bpf-datalink-type-set! bpf-list-datalink-types
            bpf-read-timeout bpf-read-timeout-set!)

(import chicken scheme foreign)

(use posix lolevel srfi-1)

(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 tweaks.  Would be overkill to use it as a dependency
(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 (ioctl port request #!optional arg)
  (let ((fd (if (port? port) (port->fileno port) port)))
    (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)))))

;;;;;;;;;;;

(define-record bpf fd)

(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* ((fd (condition-case (file-open fn (fx+ open/read open/write))
                       (e (exn i/o file) (lp (fx+ i 1) fn e))))
                 (bpf (make-bpf fd)))
            (set-finalizer! bpf bpf-close)
            ;; Length _must_ be set before interface is assigned
            (when buffer-length
              (bpf-buffer-length-set! bpf buffer-length))
            (bpf-interface-set! bpf interface)
            ;; Rather pointless to expose this as a "setter" procedure(?)
            (when promiscuous
              (ioctl fd (foreign-value "BIOCPROMISC" int)))
            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-fd bpf) (foreign-value "BIOCFLUSH" int)))

;; 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-fd bpf) (foreign-value "BIOCSBLEN" int) (location 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-fd bpf) (foreign-value "BIOCSETIF" int) (location ifreq))
    (void)))

(define (bpf-interface bpf)
  (let ((ifreq (make-blob (foreign-value "sizeof(struct ifreq)" int))))
    (ioctl (bpf-fd bpf) (foreign-value "BIOCGETIF" int) (location 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-fd bpf) (foreign-value "BIOCGBLEN" int) (location 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-fd bpf) (foreign-value "BIOCGDLT" int) (location type))
    type))

(define (bpf-datalink-type-set! bpf type)
  (let-location ((type unsigned-int type))
    (ioctl (bpf-fd bpf) (foreign-value "BIOCSDLT" int) (location 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-fd bpf) (foreign-value "BIOCGDLTLIST" int) (location 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-fd bpf) (foreign-value "BIOCGDLTLIST" int) (location 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-read-timeout bpf)
  (let ((tv (make-blob (foreign-value "sizeof(struct timeval)" int))))
    (ioctl (bpf-fd bpf) (foreign-value "BIOCGRTIMEOUT" int) (location tv))
    ((foreign-lambda* double (((c-pointer "struct timeval") tv))
       "C_return(tv->tv_sec + tv->tv_usec / 1000000.0);") (location tv))))

(define (bpf-read-timeout-set! bpf timeout)
  (let ((tv (make-blob (foreign-value "sizeof(struct timeval)" int)))
        (timeout (max 0 timeout)))
    ((foreign-lambda* void (((c-pointer "struct timeval") tv) (double timeout))
       "double i;"
       "tv->tv_usec = (int)(modf(timeout, &i) * 1000000);"
       "tv->tv_sec = (int)timeout;") (location tv) timeout)
    (ioctl (bpf-fd bpf) (foreign-value "BIOCSRTIMEOUT" int) (location tv))
    (void)))


)