Initial commit
This commit is contained in:
commit
97009ad9a7
|
@ -0,0 +1 @@
|
|||
compiled/
|
|
@ -0,0 +1,200 @@
|
|||
#lang racket/base
|
||||
;; ARP protocol, http://tools.ietf.org/html/rfc826
|
||||
;; Only does ARP-over-ethernet.
|
||||
|
||||
(provide (struct-out arp-query)
|
||||
(struct-out arp-assertion)
|
||||
spawn-arp-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require minimart)
|
||||
(require minimart/drivers/timer)
|
||||
(require minimart/demand-matcher)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "ethernet.rkt")
|
||||
|
||||
(struct arp-query (protocol protocol-address hardware-address) #:prefab)
|
||||
(struct arp-assertion (protocol protocol-address) #:prefab)
|
||||
|
||||
(define ARP-ethertype #x0806)
|
||||
(define cache-entry-lifetime-msec 1000) ;; (* 14400 1000)
|
||||
(define wakeup-interval 5000)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(struct cache-key (protocol address) #:transparent)
|
||||
(struct cache-value (expiry address) #:transparent)
|
||||
|
||||
(struct state (hwaddr cache queries assertions) #:transparent)
|
||||
|
||||
(define (spawn-arp-driver interface-name)
|
||||
(define (expire-cache cache)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(define (not-expired? v) (< now (cache-value-expiry v)))
|
||||
(for/hash [((k v) (in-hash cache)) #:when (not-expired? v)]
|
||||
(values k v)))
|
||||
|
||||
(define timer-key (list 'arp interface-name))
|
||||
|
||||
(define (set-wakeup-alarm)
|
||||
(send (set-timer timer-key wakeup-interval 'relative)))
|
||||
|
||||
(define (compute-gestalt cache)
|
||||
(gestalt-union (sub (timer-expired timer-key ?))
|
||||
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype))
|
||||
(sub (ethernet-packet-pattern interface-name #t ARP-ethertype) #:level 1)
|
||||
(pub (ethernet-packet-pattern interface-name #f ARP-ethertype))
|
||||
(sub (arp-assertion ? ?) #:level 1)
|
||||
(pub (arp-query ? ? ?) #:level 2)
|
||||
(for/fold [(g (gestalt-empty))] [((k v) (in-hash cache))]
|
||||
(gestalt-union g (pub (arp-query (cache-key-protocol k)
|
||||
(cache-key-address k)
|
||||
(cache-value-address v)))))))
|
||||
|
||||
(define (build-packet s dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
|
||||
(define hlen (bytes-length target-ha))
|
||||
(define plen (bytes-length target-pa))
|
||||
(define packet (bit-string->bytes
|
||||
(bit-string (1 :: integer bytes 2)
|
||||
(ptype :: integer bytes 2)
|
||||
hlen
|
||||
plen
|
||||
(oper :: integer bytes 2)
|
||||
(sender-ha :: binary bytes hlen)
|
||||
(sender-pa :: binary bytes plen)
|
||||
(target-ha :: binary bytes hlen)
|
||||
(target-pa :: binary bytes plen))))
|
||||
(ethernet-packet (ethernet-interface interface-name (state-hwaddr s))
|
||||
#f
|
||||
(state-hwaddr s)
|
||||
dest-mac
|
||||
ARP-ethertype
|
||||
packet))
|
||||
|
||||
(define (analyze-incoming-packet source destination body s)
|
||||
(bit-string-case body
|
||||
([ (= 1 :: integer bytes 2)
|
||||
(ptype :: integer bytes 2)
|
||||
hlen
|
||||
plen
|
||||
(oper :: integer bytes 2)
|
||||
(sender-hardware-address0 :: binary bytes hlen)
|
||||
(sender-protocol-address0 :: binary bytes plen)
|
||||
(target-hardware-address0 :: binary bytes hlen)
|
||||
(target-protocol-address0 :: binary bytes plen) ]
|
||||
(let ()
|
||||
(define sender-protocol-address (bit-string->bytes sender-protocol-address0))
|
||||
(define sender-hardware-address (bit-string->bytes sender-hardware-address0))
|
||||
(define target-protocol-address (bit-string->bytes target-protocol-address0))
|
||||
(define cache (hash-set (expire-cache (state-cache s))
|
||||
(cache-key ptype sender-protocol-address)
|
||||
(cache-value (+ (current-inexact-milliseconds)
|
||||
cache-entry-lifetime-msec)
|
||||
sender-hardware-address)))
|
||||
(transition (struct-copy state s
|
||||
[cache cache])
|
||||
(list
|
||||
(case oper
|
||||
[(1) ;; request
|
||||
(if (set-member? (state-assertions s)
|
||||
(cache-key ptype target-protocol-address))
|
||||
(send (build-packet s
|
||||
sender-hardware-address
|
||||
ptype
|
||||
2 ;; reply
|
||||
(state-hwaddr s)
|
||||
target-protocol-address
|
||||
sender-hardware-address
|
||||
sender-protocol-address))
|
||||
'())]
|
||||
[(2) '()] ;; reply
|
||||
[else '()])
|
||||
(routing-update (compute-gestalt cache))))))
|
||||
(else #f)))
|
||||
|
||||
(define queries-projection (compile-gestalt-projection (arp-query (?!) (?!) ?)))
|
||||
(define (gestalt->queries g)
|
||||
(for/set [(e (in-set (matcher-key-set (gestalt-project g 0 0 #f queries-projection))))]
|
||||
(match-define (list ptype pa) e)
|
||||
(cache-key ptype pa)))
|
||||
|
||||
(define assertions-projection (compile-gestalt-projection (arp-assertion (?!) (?!))))
|
||||
(define (gestalt->assertions g)
|
||||
(for/set [(e (matcher-key-set (gestalt-project g 0 0 #t assertions-projection)))]
|
||||
(match-define (list ptype pa) e)
|
||||
(cache-key ptype pa)))
|
||||
|
||||
(define (analyze-gestalt g s)
|
||||
(define hwaddr (gestalt->hwaddr g interface-name))
|
||||
(define new-queries (gestalt->queries g))
|
||||
(define new-assertions (gestalt->assertions g))
|
||||
(define added-queries (set-subtract new-queries (state-queries s)))
|
||||
(define added-assertions (set-subtract new-assertions (state-assertions s)))
|
||||
(define unanswered-queries (set-subtract added-queries (list->set (hash-keys (state-cache s)))))
|
||||
(define new-s (struct-copy state s
|
||||
[hwaddr hwaddr]
|
||||
[queries new-queries]
|
||||
[assertions (if hwaddr new-assertions (state-assertions s))]))
|
||||
(define (some-asserted-pa ptype)
|
||||
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype))
|
||||
(set->list new-assertions))
|
||||
['() #f]
|
||||
[(list* k _) (cache-key-address k)]))
|
||||
;; (log-info "analyze-gestalt: g:\n~a" (gestalt->pretty-string g))
|
||||
;; (log-info "analyze-gestalt: new-queries ~v" new-queries)
|
||||
;; (log-info "analyze-gestalt: new-assertions ~v" new-assertions)
|
||||
;; (log-info "analyze-gestalt: added-queries ~v" added-queries)
|
||||
;; (log-info "analyze-gestalt: added-assertions ~v" added-assertions)
|
||||
;; (log-info "analyze-gestalt: unanswered-queries ~v" unanswered-queries)
|
||||
;; (log-info "analyze-gestalt: new-s ~v" new-s)
|
||||
(transition new-s
|
||||
(list
|
||||
(for/list [(q (in-set unanswered-queries))]
|
||||
(define pa (some-asserted-pa (cache-key-protocol q)))
|
||||
(log-info "Asking for ~a from ~a"
|
||||
(pretty-bytes (cache-key-address q))
|
||||
(and pa (pretty-bytes pa)))
|
||||
(if pa
|
||||
(send (build-packet new-s
|
||||
broadcast-ethernet-address
|
||||
(cache-key-protocol q)
|
||||
1 ;; request
|
||||
hwaddr
|
||||
pa
|
||||
zero-ethernet-address
|
||||
(cache-key-address q)))
|
||||
'()))
|
||||
(when hwaddr ;; don't announce until we know our own hwaddr
|
||||
(for/list [(a (in-set added-assertions))]
|
||||
(log-info "Announcing ~a as ~a"
|
||||
(pretty-bytes (cache-key-address a))
|
||||
(pretty-bytes hwaddr))
|
||||
(send (build-packet new-s
|
||||
broadcast-ethernet-address
|
||||
(cache-key-protocol a)
|
||||
2 ;; reply -- gratuitous announcement
|
||||
hwaddr
|
||||
(cache-key-address a)
|
||||
hwaddr
|
||||
(cache-key-address a))))))))
|
||||
|
||||
(list (set-wakeup-alarm)
|
||||
(spawn (lambda (e s)
|
||||
;; (log-info "ARP: ~v // ~v" e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(analyze-gestalt g s)]
|
||||
[(message (ethernet-packet _ _ source destination _ body) _ _)
|
||||
(analyze-incoming-packet source destination body s)]
|
||||
[(message (timer-expired _ _) _ _)
|
||||
(define new-s (struct-copy state s
|
||||
[cache (expire-cache (state-cache s))]))
|
||||
(transition new-s
|
||||
(list (set-wakeup-alarm)
|
||||
(routing-update (compute-gestalt (state-cache new-s)))))]
|
||||
[_ #f]))
|
||||
(state #f (hash) (set) (set))
|
||||
(compute-gestalt (hash)))))
|
|
@ -0,0 +1,50 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide ones-complement-sum16 ip-checksum)
|
||||
|
||||
(require bitsyntax)
|
||||
(require "dump-bytes.rkt")
|
||||
|
||||
(define (ones-complement-+16 a b)
|
||||
(define c (+ a b))
|
||||
(bitwise-and #xffff (+ (arithmetic-shift c -16) c)))
|
||||
|
||||
(define (ones-complement-sum16 bs)
|
||||
(bit-string-case bs
|
||||
([ (n :: integer bytes 2) (rest :: binary) ]
|
||||
(ones-complement-+16 n (ones-complement-sum16 rest)))
|
||||
([ odd-byte ]
|
||||
(arithmetic-shift odd-byte 8))
|
||||
([ ]
|
||||
0)))
|
||||
|
||||
(define (ones-complement-negate16-safely x)
|
||||
(define r (bitwise-and #xffff (bitwise-not x)))
|
||||
(if (= r 0) #xffff r))
|
||||
|
||||
(define (ip-checksum offset blob)
|
||||
(bit-string-case blob
|
||||
([ (prefix :: binary bytes offset)
|
||||
(:: binary bytes 2)
|
||||
(suffix :: binary) ]
|
||||
(log-info "Packet pre checksum:\n~a" (dump-bytes->string blob))
|
||||
(define result (ones-complement-+16 (ones-complement-sum16 prefix)
|
||||
(ones-complement-sum16 suffix)))
|
||||
(log-info "result: ~a" (number->string result 16))
|
||||
(define checksum (ones-complement-negate16-safely result))
|
||||
(log-info "Checksum ~a" (number->string checksum 16))
|
||||
(define final-packet (bit-string (prefix :: binary)
|
||||
(checksum :: integer bytes 2)
|
||||
(suffix :: binary)))
|
||||
(log-info "Packet with checksum:\n~a" (dump-bytes->string final-packet))
|
||||
final-packet)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (ones-complement-negate16-safely
|
||||
(ones-complement-sum16 (bytes #x45 #x00 #x00 #x54
|
||||
#x00 #x00 #x00 #x00
|
||||
#x40 #x01 #x00 #x00
|
||||
#xc0 #xa8 #x01 #xde
|
||||
#xc0 #xa8 #x01 #x8f)))
|
||||
#xf5eb))
|
|
@ -0,0 +1,80 @@
|
|||
#lang racket/base
|
||||
;; Copyright (C) 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>
|
||||
;;
|
||||
;; dump-bytes.rkt is free software: you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published
|
||||
;; by the Free Software Foundation, either version 3 of the License,
|
||||
;; or (at your option) any later version.
|
||||
;;
|
||||
;; dump-bytes.rkt is distributed in the hope that it will be useful, but
|
||||
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with dump-bytes.rkt. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;; Pretty hex dump output of a Bytes.
|
||||
|
||||
(provide dump-bytes!
|
||||
dump-bytes->string
|
||||
pretty-bytes)
|
||||
|
||||
(require (only-in bitsyntax bit-string->bytes))
|
||||
(require (only-in file/sha1 bytes->hex-string))
|
||||
|
||||
(define (pretty-bytes bs)
|
||||
(bytes->hex-string (bit-string->bytes bs)))
|
||||
|
||||
;; Exact Exact -> String
|
||||
;; Returns the "0"-padded, width-digit hex representation of n
|
||||
(define (hex width n)
|
||||
(define s (number->string n 16))
|
||||
(define slen (string-length s))
|
||||
(cond
|
||||
((< slen width) (string-append (make-string (- width slen) #\0) s))
|
||||
((= slen width) s)
|
||||
((> slen width) (substring s 0 width))))
|
||||
|
||||
;; Bytes Exact -> Void
|
||||
;; Prints a pretty hex/ASCII dump of bs on (current-output-port).
|
||||
(define (dump-bytes! bs0 [requested-count #f] #:base [baseaddr 0])
|
||||
(define bs (bit-string->bytes bs0))
|
||||
(define count (if requested-count (min requested-count (bytes-length bs)) (bytes-length bs)))
|
||||
(define clipped (subbytes bs 0 count))
|
||||
(define (dump-hex i)
|
||||
(if (< i count)
|
||||
(display (hex 2 (bytes-ref clipped i)))
|
||||
(display " "))
|
||||
(display #\space))
|
||||
(define (dump-char i)
|
||||
(if (< i count)
|
||||
(let ((ch (bytes-ref clipped i)))
|
||||
(if (<= 32 ch 127)
|
||||
(display (integer->char ch))
|
||||
(display #\.)))
|
||||
(display #\space)))
|
||||
(define (for-each-between f low high)
|
||||
(do ((i low (+ i 1)))
|
||||
((= i high))
|
||||
(f i)))
|
||||
(define (dump-line i)
|
||||
(display (hex 8 (+ i baseaddr)))
|
||||
(display #\space)
|
||||
(for-each-between dump-hex i (+ i 8))
|
||||
(display ": ")
|
||||
(for-each-between dump-hex (+ i 8) (+ i 16))
|
||||
(display #\space)
|
||||
(for-each-between dump-char i (+ i 8))
|
||||
(display " : ")
|
||||
(for-each-between dump-char (+ i 8) (+ i 16))
|
||||
(newline))
|
||||
(do ((i 0 (+ i 16)))
|
||||
((>= i count))
|
||||
(dump-line i)))
|
||||
|
||||
(define (dump-bytes->string bs [requested-count #f] #:base [baseaddr 0])
|
||||
(define s (open-output-string))
|
||||
(parameterize ((current-output-port s))
|
||||
(dump-bytes! bs requested-count #:base baseaddr))
|
||||
(get-output-string s))
|
|
@ -0,0 +1,136 @@
|
|||
#lang racket/base
|
||||
;; Ethernet driver
|
||||
|
||||
(provide (struct-out ethernet-interface)
|
||||
(struct-out ethernet-packet)
|
||||
zero-ethernet-address
|
||||
broadcast-ethernet-address
|
||||
interface-names
|
||||
spawn-ethernet-driver
|
||||
gestalt->hwaddr
|
||||
ethernet-packet-pattern)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/async-channel)
|
||||
|
||||
(require minimart)
|
||||
(require minimart/demand-matcher)
|
||||
|
||||
(require packet-socket)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
|
||||
(struct ethernet-interface (name hwaddr) #:prefab)
|
||||
(struct ethernet-packet (interface from-wire? source destination ethertype body) #:prefab)
|
||||
|
||||
(define zero-ethernet-address (bytes 0 0 0 0 0 0))
|
||||
(define broadcast-ethernet-address (bytes 255 255 255 255 255 255))
|
||||
|
||||
(define interface-names (raw-interface-names))
|
||||
(log-info "Device names: ~a" interface-names)
|
||||
|
||||
(define (spawn-ethernet-driver)
|
||||
(spawn-demand-matcher (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?)
|
||||
#:demand-is-subscription? #t
|
||||
spawn-interface-tap))
|
||||
|
||||
(define (spawn-interface-tap interface-name)
|
||||
(define h (raw-interface-open interface-name))
|
||||
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
|
||||
(cond
|
||||
[(not h)
|
||||
(log-error "ethernet: Couldn't open interface ~v" interface-name)
|
||||
'()]
|
||||
[else
|
||||
(log-info "Opened interface ~a, yielding handle ~v" interface-name h)
|
||||
(define control-ch (make-async-channel))
|
||||
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
|
||||
(spawn (lambda (e h)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(if (gestalt-empty? g)
|
||||
(begin (async-channel-put control-ch 'quit)
|
||||
(transition #f (quit)))
|
||||
(begin (async-channel-put control-ch 'unblock)
|
||||
#f))]
|
||||
[(message (? ethernet-packet? p) 1 #f) ;; from metalevel 1
|
||||
(log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a):\n~a"
|
||||
(ethernet-interface-name (ethernet-packet-interface p))
|
||||
(pretty-bytes (ethernet-packet-source p))
|
||||
(pretty-bytes (ethernet-packet-destination p))
|
||||
(number->string (ethernet-packet-ethertype p) 16)
|
||||
(dump-bytes->string (ethernet-packet-body p)))
|
||||
(transition h (send p))]
|
||||
[(message (? ethernet-packet? p) 0 #f) ;; from metalevel 0
|
||||
(log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a):\n~a"
|
||||
(ethernet-interface-name (ethernet-packet-interface p))
|
||||
(pretty-bytes (ethernet-packet-source p))
|
||||
(pretty-bytes (ethernet-packet-destination p))
|
||||
(number->string (ethernet-packet-ethertype p) 16)
|
||||
(dump-bytes->string (ethernet-packet-body p)))
|
||||
(raw-interface-write h (encode-ethernet-packet p))
|
||||
#f]
|
||||
[_ #f]))
|
||||
h
|
||||
(gestalt-union (pub (ethernet-packet interface #t ? ? ? ?))
|
||||
(pub (ethernet-packet interface #t ? ? ? ?) #:level 1)
|
||||
(sub (ethernet-packet interface #f ? ? ? ?))
|
||||
(sub (ethernet-packet interface #t ? ? ? ?) #:meta-level 1)))]))
|
||||
|
||||
(define (interface-packet-read-loop interface h control-ch)
|
||||
(define (blocked)
|
||||
(match (async-channel-get control-ch)
|
||||
['unblock (unblocked)]
|
||||
['quit (void)]))
|
||||
(define (unblocked)
|
||||
(match (async-channel-try-get control-ch)
|
||||
['unblock (unblocked)]
|
||||
['quit (void)]
|
||||
[#f
|
||||
(define p (raw-interface-read h))
|
||||
(define decoded (decode-ethernet-packet interface p))
|
||||
(when decoded (send-ground-message decoded))
|
||||
(unblocked)]))
|
||||
(blocked)
|
||||
(raw-interface-close h))
|
||||
|
||||
(define (decode-ethernet-packet interface p)
|
||||
(bit-string-case p
|
||||
([ (destination :: binary bytes 6)
|
||||
(source :: binary bytes 6)
|
||||
(ethertype :: integer bytes 2)
|
||||
(body :: binary) ]
|
||||
(ethernet-packet interface
|
||||
#t
|
||||
(bit-string->bytes source)
|
||||
(bit-string->bytes destination)
|
||||
ethertype
|
||||
(bit-string->bytes body)))
|
||||
(else #f)))
|
||||
|
||||
(define (encode-ethernet-packet p)
|
||||
(match-define (ethernet-packet _ _ source destination ethertype body) p)
|
||||
(bit-string->bytes
|
||||
(bit-string (destination :: binary bytes 6)
|
||||
(source :: binary bytes 6)
|
||||
(ethertype :: integer bytes 2)
|
||||
(body :: binary))))
|
||||
|
||||
(define (hwaddr-projection interface-name)
|
||||
(compile-gestalt-projection (ethernet-packet (ethernet-interface interface-name (?!)) ? ? ? ? ?)))
|
||||
|
||||
(define (gestalt->hwaddr g interface-name)
|
||||
(define hwaddrs (matcher-key-set (gestalt-project g 0 0 #t (hwaddr-projection interface-name))))
|
||||
(match (set->list hwaddrs)
|
||||
['() #f]
|
||||
[(list (list h)) h]
|
||||
[(and hs (list* (list h) _))
|
||||
(log-warning "gestalt->hwaddr: multiple addresses for interface ~a: ~v"
|
||||
interface-name
|
||||
hs)
|
||||
h]))
|
||||
|
||||
(define (ethernet-packet-pattern interface-name from-wire? ethertype)
|
||||
(ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?))
|
|
@ -0,0 +1,156 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide ;; (struct-out ip-packet)
|
||||
spawn-ip-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require minimart)
|
||||
(require minimart/drivers/timer)
|
||||
(require minimart/demand-matcher)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "checksum.rkt")
|
||||
(require "ethernet.rkt")
|
||||
(require "arp.rkt")
|
||||
|
||||
(struct ip-packet (source destination ttl protocol options body) #:prefab) ;; TODO: more fields
|
||||
|
||||
(define IPv4-ethertype #x0800)
|
||||
|
||||
(define IP-VERSION 4)
|
||||
(define IP-MINIMUM-HEADER-LENGTH 5)
|
||||
|
||||
(define PROTOCOL-ICMP 1)
|
||||
;; (define PROTOCOL-TCP 6)
|
||||
;; (define PROTOCOL-UDP 17)
|
||||
|
||||
(define default-ttl 64)
|
||||
|
||||
(define broadcast-ip-address (bytes 255 255 255 255))
|
||||
|
||||
(struct state (hwaddr) #:transparent)
|
||||
|
||||
(define (spawn-ip-driver interface-name my-address)
|
||||
|
||||
(define (analyze-incoming-packet body s)
|
||||
;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body))
|
||||
(bit-string-case body
|
||||
([ (= IP-VERSION :: bits 4)
|
||||
(header-length :: bits 4)
|
||||
service-type
|
||||
(total-length :: bits 16)
|
||||
(id :: bits 16)
|
||||
(flags :: bits 3)
|
||||
(fragment-offset :: bits 13)
|
||||
ttl
|
||||
protocol
|
||||
(header-checksum :: bits 16)
|
||||
(source-ip0 :: binary bits 32)
|
||||
(destination-ip0 :: binary bits 32)
|
||||
(rest :: binary) ]
|
||||
(let ((source-ip (bit-string->bytes source-ip0))
|
||||
(destination-ip (bit-string->bytes destination-ip0))
|
||||
(options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH))))
|
||||
(if (and (not (equal? source-ip my-address))
|
||||
(or (equal? destination-ip my-address)
|
||||
(equal? destination-ip broadcast-ip-address))
|
||||
(>= header-length 5)
|
||||
(>= (bit-string-length body) (* header-length 4)))
|
||||
(bit-string-case rest
|
||||
([ (opts :: binary bytes options-length)
|
||||
(data :: binary) ]
|
||||
(transition s (send (ip-packet (bit-string->bytes source-ip)
|
||||
(bit-string->bytes destination-ip)
|
||||
ttl
|
||||
protocol
|
||||
(bit-string->bytes opts)
|
||||
(bit-string->bytes data))))))
|
||||
#f)))
|
||||
(else #f)))
|
||||
|
||||
(define (analyze-gestalt g s)
|
||||
(define hwaddr (gestalt->hwaddr g interface-name))
|
||||
(define new-s (struct-copy state s [hwaddr hwaddr]))
|
||||
(transition new-s '()))
|
||||
|
||||
(list
|
||||
(spawn-icmp-driver my-address)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(analyze-gestalt g s)]
|
||||
[(message (ethernet-packet _ _ _ _ _ body) _ _)
|
||||
(analyze-incoming-packet body s)]
|
||||
[(message (ip-packet _ peer-address ttl protocol options body) _ _)
|
||||
(define header-length ;; TODO: ensure options is a multiple of 4 bytes
|
||||
(+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-length options) 32)))
|
||||
(define header0
|
||||
(bit-string (IP-VERSION :: bits 4)
|
||||
(header-length :: bits 4)
|
||||
0 ;; TODO: service type
|
||||
((+ (* header-length 4)
|
||||
(/ (bit-string-length body) 8))
|
||||
:: bits 16)
|
||||
(0 :: bits 16) ;; TODO: identifier
|
||||
(0 :: bits 3) ;; TODO: flags
|
||||
(0 :: bits 13) ;; TODO: fragments
|
||||
ttl
|
||||
protocol
|
||||
(0 :: bits 16)
|
||||
(my-address :: binary bits 32)
|
||||
(peer-address :: binary bits 32)
|
||||
(options :: binary)))
|
||||
(transition s (send (ethernet-packet (ethernet-interface interface-name
|
||||
(state-hwaddr s))
|
||||
#f
|
||||
(state-hwaddr s)
|
||||
broadcast-ethernet-address
|
||||
IPv4-ethertype
|
||||
(bit-string ((ip-checksum 10 header0) :: binary)
|
||||
(body :: binary)))))]
|
||||
[_ #f]))
|
||||
(state #f)
|
||||
(gestalt-union
|
||||
(pub (arp-assertion IPv4-ethertype my-address))
|
||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype))
|
||||
(sub (ethernet-packet-pattern interface-name #t IPv4-ethertype) #:level 1)
|
||||
(pub (ethernet-packet-pattern interface-name #f IPv4-ethertype))
|
||||
(sub (ip-packet my-address ? ? ? ? ?))))))
|
||||
|
||||
(define (spawn-icmp-driver my-address)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(message (ip-packet peer-address _ _ _ _ body) _ _)
|
||||
(bit-string-case body
|
||||
([ type code (checksum :: integer bytes 2) (rest :: binary) ]
|
||||
(case type
|
||||
[(8) ;; ECHO (0 is ECHO-REPLY)
|
||||
(log-info "Ping of ~a from ~a"
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address))
|
||||
(define reply-data0 (bit-string 0
|
||||
code
|
||||
(0 :: integer bytes 2) ;; TODO
|
||||
(rest :: binary)))
|
||||
(transition s (send (ip-packet my-address
|
||||
peer-address
|
||||
default-ttl
|
||||
PROTOCOL-ICMP
|
||||
#""
|
||||
(ip-checksum 2 reply-data0))))]
|
||||
[else
|
||||
(log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
|
||||
type
|
||||
code
|
||||
checksum
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address)
|
||||
(dump-bytes->string rest))
|
||||
#f]))
|
||||
(else #f))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(gestalt-union (pub (ip-packet my-address ? ? PROTOCOL-ICMP ? ?))
|
||||
(sub (ip-packet ? my-address ? PROTOCOL-ICMP ? ?)))))
|
|
@ -0,0 +1,21 @@
|
|||
#lang minimart
|
||||
|
||||
(require minimart/drivers/timer)
|
||||
(require "ethernet.rkt")
|
||||
(require "arp.rkt")
|
||||
(require "ip.rkt")
|
||||
|
||||
(define interface "wlan0")
|
||||
|
||||
;;(log-events-and-actions? #t)
|
||||
|
||||
(spawn-timer-driver)
|
||||
(spawn-ethernet-driver)
|
||||
(spawn-arp-driver interface)
|
||||
(spawn-ip-driver interface (bytes 192 168 1 222))
|
||||
|
||||
(spawn (lambda (e s)
|
||||
;; (log-info "SPY: ~v" e)
|
||||
#f)
|
||||
(void)
|
||||
(gestalt-union (sub ? #:level 5)))
|
Loading…
Reference in New Issue