Initial commit

This commit is contained in:
Tony Garnock-Jones 2014-06-15 21:16:14 -04:00
commit 97009ad9a7
7 changed files with 644 additions and 0 deletions

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
compiled/

200
arp.rkt Normal file
View File

@ -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)))))

50
checksum.rkt Normal file
View File

@ -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))

80
dump-bytes.rkt Normal file
View File

@ -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))

136
ethernet.rkt Normal file
View File

@ -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 ?))

156
ip.rkt Normal file
View File

@ -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 ? ?)))))

21
main.rkt Normal file
View File

@ -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)))