From 97009ad9a705b46650790297a3cae15dd62ee6eb Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Sun, 15 Jun 2014 21:16:14 -0400
Subject: [PATCH] Initial commit

---
 .gitignore     |   1 +
 arp.rkt        | 200 +++++++++++++++++++++++++++++++++++++++++++++++++
 checksum.rkt   |  50 +++++++++++++
 dump-bytes.rkt |  80 ++++++++++++++++++++
 ethernet.rkt   | 136 +++++++++++++++++++++++++++++++++
 ip.rkt         | 156 ++++++++++++++++++++++++++++++++++++++
 main.rkt       |  21 ++++++
 7 files changed, 644 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 arp.rkt
 create mode 100644 checksum.rkt
 create mode 100644 dump-bytes.rkt
 create mode 100644 ethernet.rkt
 create mode 100644 ip.rkt
 create mode 100644 main.rkt

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..724bbe1
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+compiled/
diff --git a/arp.rkt b/arp.rkt
new file mode 100644
index 0000000..5d3faa6
--- /dev/null
+++ b/arp.rkt
@@ -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)))))
diff --git a/checksum.rkt b/checksum.rkt
new file mode 100644
index 0000000..7c09b2c
--- /dev/null
+++ b/checksum.rkt
@@ -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))
diff --git a/dump-bytes.rkt b/dump-bytes.rkt
new file mode 100644
index 0000000..365e59d
--- /dev/null
+++ b/dump-bytes.rkt
@@ -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))
diff --git a/ethernet.rkt b/ethernet.rkt
new file mode 100644
index 0000000..ffef106
--- /dev/null
+++ b/ethernet.rkt
@@ -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 ?))
diff --git a/ip.rkt b/ip.rkt
new file mode 100644
index 0000000..c01e61a
--- /dev/null
+++ b/ip.rkt
@@ -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 ? ?)))))
\ No newline at end of file
diff --git a/main.rkt b/main.rkt
new file mode 100644
index 0000000..3232f13
--- /dev/null
+++ b/main.rkt
@@ -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)))