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
|
;;;
;;; Interface to the /dev/bpf[N] devices (ioctls, opening/closing etc)
;;;
;;; Copyright (c) 2013 by Peter Bex, see file COPYING.BSD
;;;
(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)
(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)))
(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))))))
)
|
