From 97009ad9a705b46650790297a3cae15dd62ee6eb Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 15 Jun 2014 21:16:14 -0400 Subject: [PATCH 01/70] 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 +;; +;; 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 . + +;; 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))) From b5e73b8462e5fbb9d1acd7948f49c8595b8f4e1b Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 16 Jun 2014 10:15:53 -0400 Subject: [PATCH 02/70] Make note re: checksums --- ip.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ip.rkt b/ip.rkt index c01e61a..0763887 100644 --- a/ip.rkt +++ b/ip.rkt @@ -46,7 +46,7 @@ (fragment-offset :: bits 13) ttl protocol - (header-checksum :: bits 16) + (header-checksum :: bits 16) ;; TODO: check checksum (source-ip0 :: binary bits 32) (destination-ip0 :: binary bits 32) (rest :: binary) ] @@ -124,7 +124,7 @@ (match e [(message (ip-packet peer-address _ _ _ _ body) _ _) (bit-string-case body - ([ type code (checksum :: integer bytes 2) (rest :: binary) ] + ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum (case type [(8) ;; ECHO (0 is ECHO-REPLY) (log-info "Ping of ~a from ~a" @@ -153,4 +153,4 @@ [_ #f])) (void) (gestalt-union (pub (ip-packet my-address ? ? PROTOCOL-ICMP ? ?)) - (sub (ip-packet ? my-address ? PROTOCOL-ICMP ? ?))))) \ No newline at end of file + (sub (ip-packet ? my-address ? PROTOCOL-ICMP ? ?))))) From 57e22a5d3ca98dd5403c2cfd3f7e87eda480cde4 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 16 Jun 2014 17:51:17 -0400 Subject: [PATCH 03/70] Support #:pseudo-header in ip-checksum --- checksum.rkt | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/checksum.rkt b/checksum.rkt index 7c09b2c..a56ffb3 100644 --- a/checksum.rkt +++ b/checksum.rkt @@ -22,14 +22,16 @@ (define r (bitwise-and #xffff (bitwise-not x))) (if (= r 0) #xffff r)) -(define (ip-checksum offset blob) +(define (ip-checksum offset blob #:pseudo-header [pseudo-header #""]) (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))) + (define result (ones-complement-+16 + (ones-complement-sum16 pseudo-header) + (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)) From 630d0e29bd60b489c7ddb0585b3bbdb7092f68c0 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 16 Jun 2014 17:51:37 -0400 Subject: [PATCH 04/70] Tweaks to logging --- checksum.rkt | 8 ++++---- ethernet.rkt | 12 ++++++------ 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/checksum.rkt b/checksum.rkt index a56ffb3..e34fc13 100644 --- a/checksum.rkt +++ b/checksum.rkt @@ -27,18 +27,18 @@ ([ (prefix :: binary bytes offset) (:: binary bytes 2) (suffix :: binary) ] - (log-info "Packet pre checksum:\n~a" (dump-bytes->string blob)) + ;; (log-info "Packet pre checksum:\n~a" (dump-bytes->string blob)) (define result (ones-complement-+16 (ones-complement-sum16 pseudo-header) (ones-complement-+16 (ones-complement-sum16 prefix) (ones-complement-sum16 suffix)))) - (log-info "result: ~a" (number->string result 16)) + ;; (log-info "result: ~a" (number->string result 16)) (define checksum (ones-complement-negate16-safely result)) - (log-info "Checksum ~a" (number->string checksum 16)) + ;; (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)) + ;; (log-info "Packet with checksum:\n~a" (dump-bytes->string final-packet)) final-packet))) (module+ test diff --git a/ethernet.rkt b/ethernet.rkt index ffef106..1390023 100644 --- a/ethernet.rkt +++ b/ethernet.rkt @@ -56,20 +56,20 @@ (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" + (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~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))) + (number->string (ethernet-packet-ethertype p) 16)) + (log-info "~a" (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" + (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~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))) + (number->string (ethernet-packet-ethertype p) 16)) + (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) (raw-interface-write h (encode-ethernet-packet p)) #f] [_ #f])) From ed6f53526673734d59a0bbde3eda42805e542b3a Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 16 Jun 2014 17:52:53 -0400 Subject: [PATCH 05/70] ip-interface gestalt; remove ttl from user-accessible fields --- ip.rkt | 113 ++++++++++++++++++++++++++++++++------------------------- 1 file changed, 63 insertions(+), 50 deletions(-) diff --git a/ip.rkt b/ip.rkt index 0763887..7862cae 100644 --- a/ip.rkt +++ b/ip.rkt @@ -1,6 +1,9 @@ #lang racket/base -(provide ;; (struct-out ip-packet) +(provide (struct-out ip-packet) + (struct-out ip-interface) + ip-address->hostname + broadcast-ip-address spawn-ip-driver) (require racket/set) @@ -15,7 +18,8 @@ (require "ethernet.rkt") (require "arp.rkt") -(struct ip-packet (source destination ttl protocol options body) #:prefab) ;; TODO: more fields +(struct ip-packet (source destination protocol options body) #:prefab) ;; TODO: more fields +(struct ip-interface (address ethernet) #:prefab) (define IPv4-ethertype #x0800) @@ -28,6 +32,10 @@ (define default-ttl 64) +(define (ip-address->hostname bs) + (bit-string-case bs + ([ a b c d ] (format "~a.~a.~a.~a" a b c d)))) + (define broadcast-ip-address (bytes 255 255 255 255)) (struct state (hwaddr) #:transparent) @@ -57,13 +65,12 @@ (or (equal? destination-ip my-address) (equal? destination-ip broadcast-ip-address)) (>= header-length 5) - (>= (bit-string-length body) (* header-length 4))) + (>= (bit-string-byte-count 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)))))) @@ -73,56 +80,63 @@ (define (analyze-gestalt g s) (define hwaddr (gestalt->hwaddr g interface-name)) (define new-s (struct-copy state s [hwaddr hwaddr])) - (transition new-s '())) + (transition new-s (routing-update (compute-gestalt new-s)))) + + (define (compute-gestalt s) + (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 ? ? ? ?)) + (pub (ip-packet ? my-address ? ? ?)) + (if (state-hwaddr s) + (pub (ip-interface my-address (ethernet-interface interface-name (state-hwaddr s)))) + (gestalt-empty)))) (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 ? ? ? ? ?)))))) + (let ((state0 (state #f))) + (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 protocol options body) _ _) + (define header-length ;; TODO: ensure options is a multiple of 4 bytes + (+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4))) + (define header0 + (bit-string (IP-VERSION :: bits 4) + (header-length :: bits 4) + 0 ;; TODO: service type + ((+ (* header-length 4) (bit-string-byte-count body)) + :: bits 16) + (0 :: bits 16) ;; TODO: identifier + (0 :: bits 3) ;; TODO: flags + (0 :: bits 13) ;; TODO: fragments + default-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])) + state0 + (compute-gestalt state0))))) (define (spawn-icmp-driver my-address) (spawn (lambda (e s) (match e - [(message (ip-packet peer-address _ _ _ _ body) _ _) + [(message (ip-packet peer-address _ _ _ body) _ _) (bit-string-case body ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum (case type @@ -136,7 +150,6 @@ (rest :: binary))) (transition s (send (ip-packet my-address peer-address - default-ttl PROTOCOL-ICMP #"" (ip-checksum 2 reply-data0))))] @@ -152,5 +165,5 @@ (else #f))] [_ #f])) (void) - (gestalt-union (pub (ip-packet my-address ? ? PROTOCOL-ICMP ? ?)) - (sub (ip-packet ? my-address ? PROTOCOL-ICMP ? ?))))) + (gestalt-union (pub (ip-packet my-address ? PROTOCOL-ICMP ? ?)) + (sub (ip-packet ? my-address PROTOCOL-ICMP ? ?))))) From 7f18a83606cd8c8cd0fe814ee87daad991b7e4a3 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 16 Jun 2014 17:55:57 -0400 Subject: [PATCH 06/70] TCP --- ip.rkt | 7 + main.rkt | 4 +- tcp.rkt | 424 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 434 insertions(+), 1 deletion(-) create mode 100644 tcp.rkt diff --git a/ip.rkt b/ip.rkt index 7862cae..2688a04 100644 --- a/ip.rkt +++ b/ip.rkt @@ -125,7 +125,14 @@ (state-hwaddr s)) #f (state-hwaddr s) + + ;; N.B. to get TCP to work against + ;; linux, this HAS to be the specific + ;; MAC of the target! Broadcast + ;; won't work. broadcast-ethernet-address + + IPv4-ethertype (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary)))))] diff --git a/main.rkt b/main.rkt index 3232f13..32180a1 100644 --- a/main.rkt +++ b/main.rkt @@ -4,6 +4,7 @@ (require "ethernet.rkt") (require "arp.rkt") (require "ip.rkt") +(require "tcp.rkt") (define interface "wlan0") @@ -12,7 +13,8 @@ (spawn-timer-driver) (spawn-ethernet-driver) (spawn-arp-driver interface) -(spawn-ip-driver interface (bytes 192 168 1 222)) +(spawn-ip-driver interface (bytes 192 168 56 222)) +(spawn-tcp-driver) (spawn (lambda (e s) ;; (log-info "SPY: ~v" e) diff --git a/tcp.rkt b/tcp.rkt new file mode 100644 index 0000000..8b9107b --- /dev/null +++ b/tcp.rkt @@ -0,0 +1,424 @@ +#lang racket/base + +(provide (struct-out tcp-address) + (struct-out tcp-handle) + (struct-out tcp-listener) + (struct-out tcp-channel) + spawn-tcp-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 "ip.rkt") + +;; tcp-address/tcp-address : "kernel" tcp connection state machines +;; tcp-handle/tcp-address : "user" outbound connections +;; tcp-listener/tcp-address : "user" inbound connections + +(struct tcp-address (host port) #:prefab) +(struct tcp-handle (id) #:prefab) +(struct tcp-listener (port) #:prefab) + +(struct tcp-channel (source destination subpacket) #:prefab) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(struct tcp-packet (from-wire? + source-ip + source-port + destination-ip + destination-port + sequence-number + ack-number + flags + window-size + options + data) + #:prefab) + +(define PROTOCOL-TCP 6) + +(struct codec-state (active-state-vectors) #:transparent) + +(define (spawn-tcp-driver) + + (define (flip-statevec statevec) + (match-define (list si sp di dp) statevec) + (list di dp si sp)) + + (define (state-vector-active? statevec s) + (or (set-member? (codec-state-active-state-vectors s) statevec) + (set-member? (codec-state-active-state-vectors s) (flip-statevec statevec)))) + + (define (analyze-incoming-packet src-ip dst-ip body s) + (bit-string-case body + ([ (src-port :: integer bytes 2) + (dst-port :: integer bytes 2) + (sequence-number :: integer bytes 4) + (ack-number :: integer bytes 4) + (data-offset :: integer bits 4) + (reserved :: integer bits 3) + (ns :: integer bits 1) + (cwr :: integer bits 1) + (ece :: integer bits 1) + (urg :: integer bits 1) + (ack :: integer bits 1) + (psh :: integer bits 1) + (rst :: integer bits 1) + (syn :: integer bits 1) + (fin :: integer bits 1) + (window-size :: integer bytes 2) + (checksum :: integer bytes 2) ;; TODO: check checksum + (urgent-pointer :: integer bytes 2) + (rest :: binary) ] + (let* ((flags (set)) + (statevec (list src-ip src-port dst-ip dst-port)) + (old-active-state-vectors (codec-state-active-state-vectors s)) + (spawn-needed? (not (state-vector-active? statevec s)))) + (define-syntax-rule (set-flags! v ...) + (begin (unless (zero? v) (set! flags (set-add flags 'v))) ...)) + (set-flags! ns cwr ece urg ack psh rst syn fin) + (log-info "TCP ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a)" + (ip-address->hostname src-ip) + src-port + (ip-address->hostname dst-ip) + dst-port + sequence-number + ack-number + flags + window-size) + (when spawn-needed? (log-info " - spawn needed!")) + (bit-string-case rest + ([ (opts :: binary bytes (- (* data-offset 4) 20)) + (data :: binary) ] + (let ((packet (tcp-packet #t + src-ip + src-port + dst-ip + dst-port + sequence-number + ack-number + flags + window-size + (bit-string->bytes opts) + (bit-string->bytes data)))) + (transition (if spawn-needed? + (struct-copy codec-state s + [active-state-vectors + (set-add old-active-state-vectors statevec)]) + s) + (list + (when spawn-needed? (spawn-state-vector src-ip src-port + dst-ip dst-port)) + ;; TODO: get packet to the new state-vector process somehow + (send packet))))) + (else #f)))) + (else #f))) + + (define statevec-projection + (compile-gestalt-projection + (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?))) + + (define (analyze-gestalt g s) + (define statevecs (matcher-key-set (gestalt-project g 0 0 #f statevec-projection))) + (log-info "gestalt yielded statevecs ~v" statevecs) + (transition (struct-copy codec-state s [active-state-vectors statevecs]) '())) + + (define (deliver-outbound-packet p s) + (match-define (tcp-packet #f + src-ip + src-port + dst-ip + dst-port + sequence-number + ack-number + flags + window-size + options + data) + p) + (log-info "TCP ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a)" + (ip-address->hostname src-ip) + src-port + (ip-address->hostname dst-ip) + dst-port + sequence-number + ack-number + flags + window-size) + (define (flag-bit sym) (if (set-member? flags sym) 1 0)) + (define payload (bit-string (src-port :: integer bytes 2) + (dst-port :: integer bytes 2) + (sequence-number :: integer bytes 4) + (ack-number :: integer bytes 4) + ((+ 5 (quotient (bit-string-byte-count options) 4)) + :: integer bits 4) ;; TODO: enforce 4-byte alignment + (0 :: integer bits 3) + ((flag-bit 'ns) :: integer bits 1) + ((flag-bit 'cwr) :: integer bits 1) + ((flag-bit 'ece) :: integer bits 1) + ((flag-bit 'urg) :: integer bits 1) + ((flag-bit 'ack) :: integer bits 1) + ((flag-bit 'psh) :: integer bits 1) + ((flag-bit 'rst) :: integer bits 1) + ((flag-bit 'syn) :: integer bits 1) + ((flag-bit 'fin) :: integer bits 1) + (window-size :: integer bytes 2) + (0 :: integer bytes 2) ;; checksum location + (0 :: integer bytes 2) ;; TODO: urgent pointer + (data :: binary))) + (define pseudo-header (bit-string (src-ip :: binary bytes 4) + (dst-ip :: binary bytes 4) + 0 + PROTOCOL-TCP + ((bit-string-byte-count payload) :: integer bytes 2))) + (transition s (send (ip-packet src-ip dst-ip PROTOCOL-TCP #"" + (ip-checksum 16 payload #:pseudo-header pseudo-header))))) + + (spawn (lambda (e s) + (match e + [(routing-update g) + (analyze-gestalt g s)] + [(message (ip-packet src dst _ _ body) _ _) + (analyze-incoming-packet src dst body s)] + [(message (? tcp-packet? p) _ _) + #:when (not (tcp-packet-from-wire? p)) + (deliver-outbound-packet p s)] + [_ #f])) + (codec-state (set)) + (gestalt-union (pub (ip-packet ? ? PROTOCOL-TCP ? ?)) + (sub (ip-packet ? ? PROTOCOL-TCP ? ?)) + (sub (tcp-packet #f ? ? ? ? ? ? ? ? ? ?)) + (pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?)) + (pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?) + #:level 1)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(struct buffer (data ;; bit-string + seqn ;; names leftmost byte in data + window ;; counts bytes from leftmost byte in data + finished?) ;; boolean: true after FIN + #:transparent) + +(struct conn-state (outbound ;; buffer + inbound ;; buffer + syn-acked? ;; boolean + latest-activity-time) ;; from current-inexact-milliseconds + #:transparent) + +(define transmit-check-interval-msec 100) +(define inbound-buffer-limit 65535) +(define maximum-segment-size 536) ;; bytes +(define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout + +(define (spawn-state-vector src-ip src-port dst-ip dst-port) + (define src (tcp-address (ip-address->hostname src-ip) src-port)) + (define dst (tcp-address (ip-address->hostname dst-ip) dst-port)) + (define (timer-name kind) (list 'tcp-timer kind src dst)) + + (define (next-expected-seqn s) + (define b (conn-state-inbound s)) + (define v (buffer-seqn b)) + (and v (seq+ v (bit-string-byte-count (buffer-data b))))) + + (define (buffer-push b data) + (struct-copy buffer b [data (bit-string-append (buffer-data b) data)])) + + ;; ConnState -> ConnState + (define (set-inbound-seqn seqn s) + (struct-copy conn-state s + [inbound (struct-copy buffer (conn-state-inbound s) [seqn seqn])])) + + ;; Bitstring ConnState -> Transition + (define (incorporate-segment data s) + (transition + (if (buffer-finished? (conn-state-inbound s)) + s + (struct-copy conn-state s [inbound (buffer-push (conn-state-inbound s) data)])) + '())) + + (define (seq+ a b) (bitwise-and #xffffffff (+ a b))) + + ;; Always positive + (define (seq- larger smaller) + (if (< larger smaller) ;; wraparound has occurred + (+ (- larger smaller) #x100000000) + (- larger smaller))) + + (define (seq> a b) + (< (seq- a b) #x80000000)) + + ;; ConnState -> Transition + (define (deliver-inbound-locally s) + (define b (conn-state-inbound s)) + (if (bit-string-empty? (buffer-data b)) + (transition s '()) + (let ((chunk (bit-string->bytes (buffer-data b)))) + (transition (struct-copy conn-state s + [inbound (struct-copy buffer b + [data #""] + [seqn (seq+ (buffer-seqn b) (bytes-length chunk))])]) + (send (tcp-channel src dst chunk)))))) + + ;; (Setof Symbol) -> ConnState -> Transition + (define ((check-fin flags) s) + (define b (conn-state-inbound s)) + (unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally + (error 'check-fin "Nonempty inbound buffer")) + (transition + (if (set-member? flags 'fin) + (struct-copy conn-state s + [inbound (struct-copy buffer b + [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte + [finished? #t])]) + s) + '())) + + ;; Boolean Nat -> ConnState -> Transition + (define ((discard-acknowledged-outbound ack? ackn) s) + (transition + (if (not ack?) + s + (let* ((b (conn-state-outbound s)) + (limit (seq+ (buffer-seqn b) (bit-string-byte-count (buffer-data b)))) + (ackn (if (seq> ackn limit) limit ackn)) + (dist (seq- ackn (buffer-seqn b)))) + (define-values (discarded-acknowledged-data remaining-data) + (bit-string-split-at (buffer-data b) (* dist 8))) ;; bit offset! + (struct-copy conn-state s + [outbound (struct-copy buffer b [data remaining-data] [seqn ackn])] + [syn-acked? (or (conn-state-syn-acked? s) + (positive? dist))]))) + '())) + + ;; Nat -> ConnState -> Transition + (define ((update-outbound-window peer-window) s) + (transition (struct-copy conn-state s + [outbound (struct-copy buffer (conn-state-outbound s) + [window peer-window])]) + '())) + + ;; ConnState -> Boolean + (define (all-output-acknowledged? s) + (bit-string-empty? (buffer-data (conn-state-outbound s)))) + + ;; ConnState -> Transition + (define ((send-outbound old-ackn) s) + (define b (conn-state-outbound s)) + (define pending-byte-count (max 0 (- (bit-string-byte-count (buffer-data b)) + (if (buffer-finished? b) 1 0)))) + (define segment-size (min maximum-segment-size + (buffer-window b) + pending-byte-count)) + (define segment-offset (if (conn-state-syn-acked? s) 0 1)) + (define-values (chunk0 remaining-data) + (bit-string-split-at (buffer-data b) (* segment-size 8))) ;; bit offset! + (define-values (discarded-dummy-syn-data chunk) + (bit-string-split-at chunk0 (* segment-offset 8))) ;; bit offset! + (define ackn (next-expected-seqn s)) + (define flags (set)) + (when ackn + (set! flags (set-add flags 'ack))) + (when (not (conn-state-syn-acked? s)) + (set! flags (set-add flags 'syn))) + (when (and (buffer-finished? b) + (= segment-size pending-byte-count) + (not (all-output-acknowledged? s))) + (set! flags (set-add flags 'fin))) + (define window (min 65535 ;; limit of field width + (max 0 ;; can't be negative + (- (buffer-window (conn-state-inbound s)) + (bit-string-byte-count + (buffer-data (conn-state-inbound s))))))) + (transition s + (unless (and (equal? ackn old-ackn) + (conn-state-syn-acked? s) + (zero? (bit-string-byte-count chunk))) + (send (tcp-packet #f + dst-ip + dst-port + src-ip + src-port + (buffer-seqn b) + (or ackn 0) + flags + window + #"" + chunk))))) + + ;; ConnState -> Transition + (define (bump-activity-time s) + (transition (struct-copy conn-state s + [latest-activity-time (current-inexact-milliseconds)]) + '())) + + ;; ConnState -> Transition + (define (quit-when-done s) + (if (and (buffer-finished? (conn-state-outbound s)) + (buffer-finished? (conn-state-inbound s)) + (all-output-acknowledged? s) + (> (- (current-inexact-milliseconds) (conn-state-latest-activity-time s)) + (* 2 1000 maximum-segment-lifetime-sec))) + (transition s (quit)) + (transition s '()))) + + ;; Action + (define send-set-transmit-check-timer + (send (set-timer (timer-name 'transmit-check) + transmit-check-interval-msec + 'relative))) + + (define (state-vector-behavior e s) + (define old-ackn (buffer-seqn (conn-state-inbound s))) + (match e + [(message (tcp-packet #t _ _ _ _ seqn ackn flags window options data) _ _) + (define expected (next-expected-seqn s)) + (sequence-transitions (if (not expected) ;; haven't seen syn yet... + (if (set-member? flags 'syn) ;; ... and this is it + (incorporate-segment data + (set-inbound-seqn (seq+ seqn 1) s)) + (transition s '())) + (if (= expected seqn) + (incorporate-segment data s) + (transition s '()))) + deliver-inbound-locally + (check-fin flags) + (discard-acknowledged-outbound (set-member? flags 'ack) ackn) + (update-outbound-window window) + (send-outbound old-ackn) + bump-activity-time + quit-when-done)] + [(message (timer-expired (== (timer-name 'transmit-check)) _) _ _) + (sequence-transitions (transition s send-set-transmit-check-timer) + (send-outbound old-ackn) + quit-when-done)] + [_ #f])) + + ;; (local-require racket/trace) + ;; (trace state-vector-behavior) + + (define initial-outbound-seqn + ;; Yuck + (inexact->exact (truncate (* #x100000000 (random))))) + + ;; TODO accept input from user process + ;; TODO append a dummy byte at FIN position in outbound buffer + (list + send-set-transmit-check-timer + (spawn state-vector-behavior + (conn-state (buffer #"!" initial-outbound-seqn 0 #f) ;; dummy data at SYN position + (buffer #"" #f inbound-buffer-limit #f) + #f + (current-inexact-milliseconds)) + (gestalt-union (sub (timer-expired (timer-name ?) ?)) + (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?)) + (pub (tcp-packet #f dst-ip dst-port src-ip src-port ? ? ? ? ? ?)) + (sub (tcp-channel dst src ?)) + (pub (tcp-channel src dst ?)))))) \ No newline at end of file From 7f5fa1d7c810109cc66c242e504f99afeac89059 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 17 Jun 2014 12:06:16 -0400 Subject: [PATCH 07/70] Queries are at level 1 --- arp.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/arp.rkt b/arp.rkt index 5d3faa6..6ad7d06 100644 --- a/arp.rkt +++ b/arp.rkt @@ -117,7 +117,7 @@ (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))))] + (for/set [(e (in-set (matcher-key-set (gestalt-project g 0 1 #f queries-projection))))] (match-define (list ptype pa) e) (cache-key ptype pa))) From 0d11381954b16378741bf7f3740d33f45efd3fd9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 17 Jun 2014 12:06:27 -0400 Subject: [PATCH 08/70] Expire arp cache entries at a more reasonable timeout --- arp.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/arp.rkt b/arp.rkt index 6ad7d06..40f5f0f 100644 --- a/arp.rkt +++ b/arp.rkt @@ -20,7 +20,7 @@ (struct arp-assertion (protocol protocol-address) #:prefab) (define ARP-ethertype #x0806) -(define cache-entry-lifetime-msec 1000) ;; (* 14400 1000) +(define cache-entry-lifetime-msec (* 14400 1000)) (define wakeup-interval 5000) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From ad56852b5b0cf4b695dfb193fb764becac635b1a Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 17 Jun 2014 12:06:43 -0400 Subject: [PATCH 09/70] Silence ethernet noise --- ethernet.rkt | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/ethernet.rkt b/ethernet.rkt index 1390023..f036540 100644 --- a/ethernet.rkt +++ b/ethernet.rkt @@ -56,20 +56,20 @@ (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)" - (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)) - (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) + ;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~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)) + ;; (log-info "~a" (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)" - (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)) - (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) + ;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~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)) + ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) (raw-interface-write h (encode-ethernet-packet p)) #f] [_ #f])) From c5530c7b9cc028b12bb72f8a00656f47221c73a9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 17 Jun 2014 12:07:05 -0400 Subject: [PATCH 10/70] Run ARP by spawning a process per packet (!) --- ip.rkt | 59 +++++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 44 insertions(+), 15 deletions(-) diff --git a/ip.rkt b/ip.rkt index 2688a04..e0b923f 100644 --- a/ip.rkt +++ b/ip.rkt @@ -121,25 +121,54 @@ (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) - - ;; N.B. to get TCP to work against - ;; linux, this HAS to be the specific - ;; MAC of the target! Broadcast - ;; won't work. - broadcast-ethernet-address - - - IPv4-ethertype - (bit-string ((ip-checksum 10 header0) :: binary) - (body :: binary)))))] + (define full-packet (bit-string ((ip-checksum 10 header0) :: binary) + (body :: binary))) + (transition s (spawn-packet-sender interface-name + (state-hwaddr s) + peer-address + full-packet))] [_ #f])) state0 (compute-gestalt state0))))) +(define arp-result-projection (compile-gestalt-projection (arp-query ? ? (?!)))) + +(define (spawn-packet-sender interface-name local-hwaddr remote-ip full-packet) + (define timer-id (list (gensym 'packet) remote-ip)) + (list + (send (set-timer timer-id 5000 'relative)) + (spawn (lambda (e s) + (match e + [(routing-update g) + (define all-results + (set->list (matcher-key-set (gestalt-project g 0 0 #t arp-result-projection)))) + (match all-results + [#f (error 'ip "Someone has published a wildcard arp result")] + ['() ;; no results yet, keep waiting + #f] + [(list* (list remote-hwaddr) rest) + (unless (null? rest) + (log-warning "Ambiguous arp result for ~a: ~v" + (ip-address->hostname remote-ip) + all-results)) + (transition s + (list + (send (ethernet-packet (ethernet-interface interface-name + local-hwaddr) + #f + local-hwaddr + remote-hwaddr + IPv4-ethertype + full-packet)) + (quit)))])] + [(message (timer-expired _ _) _ _) + (log-warning "ARP lookup failed, packet dropped") + (transition s (quit))] + [_ #f])) + (void) + (gestalt-union (sub (timer-expired timer-id ?)) + (sub (arp-query IPv4-ethertype remote-ip ?) #:level 1))))) + (define (spawn-icmp-driver my-address) (spawn (lambda (e s) (match e From ccc5775f00206035b782a9bcf724df47a0a1e4be Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 17 Jun 2014 17:01:22 -0400 Subject: [PATCH 11/70] Use matcher-key-set/single and set-first --- ethernet.rkt | 17 ++++++++--------- ip.rkt | 10 +++++----- 2 files changed, 13 insertions(+), 14 deletions(-) diff --git a/ethernet.rkt b/ethernet.rkt index f036540..c3b6da9 100644 --- a/ethernet.rkt +++ b/ethernet.rkt @@ -122,15 +122,14 @@ (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 hwaddrs + (matcher-key-set/single (gestalt-project g 0 0 #t (hwaddr-projection interface-name)))) + (case (set-count hwaddrs) + [(0) #f] + [(1) (set-first hwaddrs)] + [else + (log-warning "gestalt->hwaddr: multiple addresses for interface ~a: ~v" interface-name hwaddrs) + (set-first hwaddrs)])) (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 index e0b923f..bd565a5 100644 --- a/ip.rkt +++ b/ip.rkt @@ -141,13 +141,13 @@ (match e [(routing-update g) (define all-results - (set->list (matcher-key-set (gestalt-project g 0 0 #t arp-result-projection)))) + (matcher-key-set/single (gestalt-project g 0 0 #t arp-result-projection))) (match all-results [#f (error 'ip "Someone has published a wildcard arp result")] - ['() ;; no results yet, keep waiting - #f] - [(list* (list remote-hwaddr) rest) - (unless (null? rest) + [(? set-empty?) #f] ;; no results yet, keep waiting + [_ + (define remote-hwaddr (set-first all-results)) + (unless (= 1 (set-count all-results)) (log-warning "Ambiguous arp result for ~a: ~v" (ip-address->hostname remote-ip) all-results)) From 4de4180c67c4abdf0d6974770a46b3ff1a7e6c48 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 17 Jun 2014 17:02:32 -0400 Subject: [PATCH 12/70] Actual somewhat-working TCP server -- the chat example from minimart --- main.rkt | 65 ++++++++++++- tcp.rkt | 284 +++++++++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 295 insertions(+), 54 deletions(-) diff --git a/main.rkt b/main.rkt index 32180a1..fb6d194 100644 --- a/main.rkt +++ b/main.rkt @@ -1,12 +1,13 @@ #lang minimart +(require minimart/demand-matcher) (require minimart/drivers/timer) (require "ethernet.rkt") (require "arp.rkt") (require "ip.rkt") (require "tcp.rkt") -(define interface "wlan0") +(define interface "vboxnet0") ;;(log-events-and-actions? #t) @@ -16,8 +17,66 @@ (spawn-ip-driver interface (bytes 192 168 56 222)) (spawn-tcp-driver) +(let () + (local-require racket/set racket/string) + + (define (spawn-session them us) + (define user (gensym 'user)) + (define remote-detector (compile-gestalt-projection (?!))) + (define peer-detector (compile-gestalt-projection `(,(?!) says ,?))) + (define (send-to-remote fmt . vs) + (send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) + (define (say who fmt . vs) + (unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs)))) + (list (send-to-remote "Welcome, ~a.\n" user) + (spawn (lambda (e old-peers) + (log-info "~a: ~v --> ~v" user e old-peers) + (match e + [(message (tcp-channel _ _ bs) 1 #f) + (transition old-peers + (send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))] + [(message `(,who says ,what) 0 #f) + (transition old-peers (say who "says: ~a" what))] + [(routing-update g) + (define new-peers + (matcher-key-set/single (gestalt-project g 0 0 #t peer-detector))) + (transition + new-peers + (list (when (matcher-empty? (gestalt-project g 1 0 #t remote-detector)) + (quit)) + (for/list [(who (set-subtract new-peers old-peers))] + (say who "arrived.")) + (for/list [(who (set-subtract old-peers new-peers))] + (say who "departed."))))] + [#f #f])) + (set) + (gestalt-union (sub `(,? says ,?)) + (sub `(,? says ,?) #:level 1) + (pub `(,user says ,?)) + (sub (tcp-channel them us ?) #:meta-level 1) + (sub (tcp-channel them us ?) #:meta-level 1 #:level 1) + (pub (tcp-channel us them ?) #:meta-level 1))))) + + (spawn-world + (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 5999)) ?) + #:meta-level 1 + spawn-session)) + + ) + (spawn (lambda (e s) - ;; (log-info "SPY: ~v" e) + (local-require racket/pretty) + (match e + [(message m _ _) + (pretty-write `(MAIN ,m))] + [(routing-update g) + (printf "MAIN gestalt:\n") + (pretty-print-gestalt g)] + [_ (void)]) + (flush-output) #f) (void) - (gestalt-union (sub ? #:level 5))) + (gestalt-union + ;;(sub ? #:level 5) + (sub (tcp-channel ? ? ?) #:level 5) + )) diff --git a/tcp.rkt b/tcp.rkt index 8b9107b..6e3c63b 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -21,14 +21,15 @@ ;; tcp-handle/tcp-address : "user" outbound connections ;; tcp-listener/tcp-address : "user" inbound connections +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Protocol messages + (struct tcp-address (host port) #:prefab) (struct tcp-handle (id) #:prefab) (struct tcp-listener (port) #:prefab) (struct tcp-channel (source destination subpacket) #:prefab) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (struct tcp-packet (from-wire? source-ip source-port @@ -42,11 +43,125 @@ data) #:prefab) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; User-accessible driver startup + +(define (spawn-tcp-driver) + (list (spawn-demand-matcher (tcp-channel ? (?! (tcp-listener ?)) ?) + #:demand-is-subscription? #t + #:demand-level 1 + #:supply-level 2 + (lambda (server-addr) + (match-define (tcp-listener port) server-addr) + (spawn-demand-matcher + (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-address ? port)) ?) + (spawn-relay server-addr)))) + (spawn-demand-matcher (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?) + (lambda (local-addr remote-addr) + (send (tcp-port-allocation-request local-addr remote-addr)))) + (spawn-port-allocator) + (spawn-kernel-tcp-driver))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Port allocator + +(struct tcp-port-allocation-request (local-addr remote-addr) #:prefab) + +(struct port-allocator-state (used-ports local-ips) #:transparent) + +(define (spawn-port-allocator) + (define port-projector + (compile-gestalt-projection (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?))) + (define ip-projector + (compile-gestalt-projection (ip-interface (?!) ?))) + + ;; TODO: Choose a sensible IP address for the outbound connection. + ;; We don't have enough information to do this well at the moment, + ;; so just pick some available local IP address. + ;; + ;; Interesting note: In some sense, the right answer is "?". This + ;; would give us a form of mobility, where IP addresses only route + ;; to a given bucket-of-state and ONLY the port number selects a + ;; substate therein. That's not how TCP is defined however so we + ;; can't do that. + (define (appropriate-ip s) + (set-first (port-allocator-state-local-ips s))) + + (spawn (lambda (e s) + (match e + [(routing-update g) + (define extracted-ips (matcher-key-set (gestalt-project g 0 0 #t ip-projector))) + (define extracted-ports (matcher-key-set (gestalt-project g 0 0 #f port-projector))) + (if (or (not extracted-ports) (not extracted-ips)) + (error 'tcp "Someone has published a wildcard TCP address or IP interface") + (transition (let ((local-ips (for/set [(e (in-set extracted-ips))] (car e)))) + (port-allocator-state + (for/fold [(s (set))] [(e (in-set extracted-ports))] + (match-define (list si sp di dp) e) + (let* ((s (if (set-member? local-ips si) (set-add s sp) s)) + (s (if (set-member? local-ips di) (set-add s dp) s))) + s)) + local-ips)) + '()))] + [(message (tcp-port-allocation-request local-addr remote-addr) _ _) + (define currently-used-ports (port-allocator-state-used-ports s)) + (let randomly-allocate-until-unused () + (define p (+ 1024 (random 64512))) + (if (set-member? currently-used-ports p) + (randomly-allocate-until-unused) + (transition (struct-copy port-allocator-state s + [used-ports (set-add currently-used-ports p)]) + ((spawn-relay local-addr) + remote-addr + (tcp-channel (appropriate-ip s) p)))))] + [_ #f])) + (port-allocator-state (set) (set)) + (gestalt-union (sub (tcp-port-allocation-request ? ?)) + (sub (projection->pattern ip-projector) #:level 1) + (pub (projection->pattern port-projector) #:level 1)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Relay between kernel-level and user-level + +(define ((spawn-relay local-user-addr) remote-addr local-tcp-addr) + (define local-peer-traffic (pub (tcp-channel remote-addr local-user-addr ?) #:level 1)) + (define remote-peer-traffic (sub (tcp-channel remote-addr local-tcp-addr ?) #:level 1)) + (spawn (lambda (e seen-local-peer?) + (local-require racket/pretty) + (pretty-write `(RELAY (local-user-addr ,local-user-addr) + (remote-addr ,remote-addr) + (local-tcp-addr ,local-tcp-addr) + (seen-local-peer? ,seen-local-peer?) + (e ,e))) + (flush-output) + (match e + [(routing-update g) + (define local-peer-absent? (gestalt-empty? (gestalt-filter g local-peer-traffic))) + (transition (or seen-local-peer? (not local-peer-absent?)) + (when (or (and seen-local-peer? local-peer-absent?) + (gestalt-empty? (gestalt-filter g remote-peer-traffic))) + (quit)))] + [(message (tcp-channel (== local-user-addr) (== remote-addr) bs) _ _) + (transition seen-local-peer? (send (tcp-channel local-tcp-addr remote-addr bs)))] + [(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs) _ _) + (transition seen-local-peer? (send (tcp-channel remote-addr local-user-addr bs)))] + [_ #f])) + #f + (gestalt-union local-peer-traffic + remote-peer-traffic + (sub (tcp-channel remote-addr local-tcp-addr ?)) + (sub (tcp-channel local-user-addr remote-addr ?)) + (pub (tcp-channel remote-addr local-user-addr ?)) + (pub (tcp-channel local-tcp-addr remote-addr ?))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Codec & kernel-level driver + (define PROTOCOL-TCP 6) (struct codec-state (active-state-vectors) #:transparent) -(define (spawn-tcp-driver) +(define (spawn-kernel-tcp-driver) (define (flip-statevec statevec) (match-define (list si sp di dp) statevec) @@ -80,7 +195,8 @@ (let* ((flags (set)) (statevec (list src-ip src-port dst-ip dst-port)) (old-active-state-vectors (codec-state-active-state-vectors s)) - (spawn-needed? (not (state-vector-active? statevec s)))) + (spawn-needed? (and (not (state-vector-active? statevec s)) + (zero? rst)))) ;; don't bother spawning if it's a rst (define-syntax-rule (set-flags! v ...) (begin (unless (zero? v) (set! flags (set-add flags 'v))) ...)) (set-flags! ns cwr ece urg ack psh rst syn fin) @@ -200,6 +316,7 @@ #:level 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Per-connection state vector process (struct buffer (data ;; bit-string seqn ;; names leftmost byte in data @@ -210,7 +327,8 @@ (struct conn-state (outbound ;; buffer inbound ;; buffer syn-acked? ;; boolean - latest-activity-time) ;; from current-inexact-milliseconds + latest-activity-time ;; from current-inexact-milliseconds + local-peer-seen?) ;; boolean #:transparent) (define transmit-check-interval-msec 100) @@ -255,6 +373,17 @@ (define (seq> a b) (< (seq- a b) #x80000000)) + ;; ConnState -> Gestalt + (define (compute-gestalt s) + (gestalt-union (sub (timer-expired (timer-name ?) ?)) + (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?)) + (pub (tcp-packet #f dst-ip dst-port src-ip src-port ? ? ? ? ? ?)) + (sub (tcp-channel dst src ?)) + (if (not (buffer-finished? (conn-state-inbound s))) + (pub (tcp-channel src dst ?)) + (gestalt-empty)) + (pub (tcp-channel src dst ?) #:level 1))) + ;; ConnState -> Transition (define (deliver-inbound-locally s) (define b (conn-state-inbound s)) @@ -272,16 +401,15 @@ (define b (conn-state-inbound s)) (unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally (error 'check-fin "Nonempty inbound buffer")) - (transition - (if (set-member? flags 'fin) - (struct-copy conn-state s - [inbound (struct-copy buffer b - [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte - [finished? #t])]) - s) - '())) + (if (set-member? flags 'fin) + (let ((new-s (struct-copy conn-state s + [inbound (struct-copy buffer b + [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte + [finished? #t])]))) + (transition new-s (routing-update (compute-gestalt new-s)))) + (transition s '()))) - ;; Boolean Nat -> ConnState -> Transition + ;; Boolean SeqNum -> ConnState -> Transition (define ((discard-acknowledged-outbound ack? ackn) s) (transition (if (not ack?) @@ -309,13 +437,15 @@ (define (all-output-acknowledged? s) (bit-string-empty? (buffer-data (conn-state-outbound s)))) - ;; ConnState -> Transition + ;; (Option SeqNum) -> ConnState -> Transition (define ((send-outbound old-ackn) s) (define b (conn-state-outbound s)) (define pending-byte-count (max 0 (- (bit-string-byte-count (buffer-data b)) (if (buffer-finished? b) 1 0)))) + (define segment-size (min maximum-segment-size - (buffer-window b) + (if (conn-state-syn-acked? s) (buffer-window b) 1) + ;; ^ can only send SYN until SYN is acked pending-byte-count)) (define segment-offset (if (conn-state-syn-acked? s) 0 1)) (define-values (chunk0 remaining-data) @@ -329,8 +459,9 @@ (when (not (conn-state-syn-acked? s)) (set! flags (set-add flags 'syn))) (when (and (buffer-finished? b) + (conn-state-syn-acked? s) (= segment-size pending-byte-count) - (not (all-output-acknowledged? s))) + (not (all-output-acknowledged? s))) ;; TODO: reexamine. This looks fishy (set! flags (set-add flags 'fin))) (define window (min 65535 ;; limit of field width (max 0 ;; can't be negative @@ -340,12 +471,14 @@ (transition s (unless (and (equal? ackn old-ackn) (conn-state-syn-acked? s) + (not (set-member? flags 'fin)) (zero? (bit-string-byte-count chunk))) - (send (tcp-packet #f - dst-ip - dst-port - src-ip - src-port + (local-require racket/pretty) + (pretty-write `(send-outbound (old-ackn ,old-ackn) + (s ,s) + (flags ,flags))) + (flush-output) + (send (tcp-packet #f dst-ip dst-port src-ip src-port (buffer-seqn b) (or ackn 0) flags @@ -361,13 +494,13 @@ ;; ConnState -> Transition (define (quit-when-done s) - (if (and (buffer-finished? (conn-state-outbound s)) - (buffer-finished? (conn-state-inbound s)) - (all-output-acknowledged? s) - (> (- (current-inexact-milliseconds) (conn-state-latest-activity-time s)) - (* 2 1000 maximum-segment-lifetime-sec))) - (transition s (quit)) - (transition s '()))) + (transition s (when (and (buffer-finished? (conn-state-outbound s)) + (buffer-finished? (conn-state-inbound s)) + (all-output-acknowledged? s) + (> (- (current-inexact-milliseconds) + (conn-state-latest-activity-time s)) + (* 2 1000 maximum-segment-lifetime-sec))) + (quit)))) ;; Action (define send-set-transmit-check-timer @@ -375,23 +508,74 @@ transmit-check-interval-msec 'relative))) + ;; ConnState -> Transition + (define (reset seqn ackn is-fin? s) + (log-warning "Sending RST from ~a:~a to ~a:~a" + (ip-address->hostname dst-ip) + dst-port + (ip-address->hostname src-ip) + src-port) + (transition s + (list + (send (tcp-packet #f dst-ip dst-port src-ip src-port + seqn + (seq+ ackn (if is-fin? 1 0)) + (set 'ack 'rst) + 0 + #"" + #"")) + (quit)))) + + ;; ConnState -> ConnState + (define (close-outbound-stream s) + (transition + (struct-copy conn-state s + [outbound (struct-copy buffer (buffer-push (conn-state-outbound s) #"!") ;; dummy FIN byte + [finished? #t])]) + '())) + (define (state-vector-behavior e s) (define old-ackn (buffer-seqn (conn-state-inbound s))) (match e + [(routing-update g) + (log-info "State vector routing-update:\n~a" (gestalt->pretty-string g)) + (define local-peer-present? (not (gestalt-empty? g))) + (cond + [(and local-peer-present? (not (conn-state-local-peer-seen? s))) + (transition (struct-copy conn-state s [local-peer-seen? #t]) '())] + [(and (not local-peer-present?) (conn-state-local-peer-seen? s)) + (log-info "Closing outbound stream.") + (sequence-transitions (close-outbound-stream s) + (send-outbound old-ackn) + bump-activity-time + quit-when-done)] + [else #f])] [(message (tcp-packet #t _ _ _ _ seqn ackn flags window options data) _ _) (define expected (next-expected-seqn s)) - (sequence-transitions (if (not expected) ;; haven't seen syn yet... - (if (set-member? flags 'syn) ;; ... and this is it - (incorporate-segment data - (set-inbound-seqn (seq+ seqn 1) s)) - (transition s '())) - (if (= expected seqn) - (incorporate-segment data s) - (transition s '()))) - deliver-inbound-locally - (check-fin flags) - (discard-acknowledged-outbound (set-member? flags 'ack) ackn) - (update-outbound-window window) + (if (and (not expected) ;; no syn yet + (not (set-member? flags 'syn))) ;; and this isn't it + (reset ackn ;; this is *our* seqn + seqn ;; this is what we should acknowledge... + (set-member? flags 'fin) ;; ... +1, if fin is set + s) + (sequence-transitions (cond + [(not expected) ;; haven't seen syn yet, but we know this is it + (incorporate-segment data (set-inbound-seqn (seq+ seqn 1) s))] + [(= expected seqn) + (incorporate-segment data s)] + [else + (transition s '())]) + deliver-inbound-locally + (check-fin flags) + (discard-acknowledged-outbound (set-member? flags 'ack) ackn) + (update-outbound-window window) + (send-outbound old-ackn) + bump-activity-time + quit-when-done))] + [(message (tcp-channel _ _ bs) _ _) + (sequence-transitions (transition (struct-copy conn-state s + [outbound (buffer-push (conn-state-outbound s) bs)]) + '()) (send-outbound old-ackn) bump-activity-time quit-when-done)] @@ -412,13 +596,11 @@ ;; TODO append a dummy byte at FIN position in outbound buffer (list send-set-transmit-check-timer - (spawn state-vector-behavior - (conn-state (buffer #"!" initial-outbound-seqn 0 #f) ;; dummy data at SYN position - (buffer #"" #f inbound-buffer-limit #f) - #f - (current-inexact-milliseconds)) - (gestalt-union (sub (timer-expired (timer-name ?) ?)) - (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?)) - (pub (tcp-packet #f dst-ip dst-port src-ip src-port ? ? ? ? ? ?)) - (sub (tcp-channel dst src ?)) - (pub (tcp-channel src dst ?)))))) \ No newline at end of file + (let ((state0 (conn-state (buffer #"!" initial-outbound-seqn 0 #f) ;; dummy data at SYN position + (buffer #"" #f inbound-buffer-limit #f) + #f + (current-inexact-milliseconds) + #f))) + (spawn state-vector-behavior + state0 + (compute-gestalt state0))))) From 03a6455594d7301a1a1b182afc7d7fbcdbb610b7 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 17 Jun 2014 17:30:20 -0400 Subject: [PATCH 13/70] Use bit-string-take and bit-string-drop (new in racket-bitsyntax 4.1) --- tcp.rkt | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index 6e3c63b..e897ea4 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -418,8 +418,7 @@ (limit (seq+ (buffer-seqn b) (bit-string-byte-count (buffer-data b)))) (ackn (if (seq> ackn limit) limit ackn)) (dist (seq- ackn (buffer-seqn b)))) - (define-values (discarded-acknowledged-data remaining-data) - (bit-string-split-at (buffer-data b) (* dist 8))) ;; bit offset! + (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset! (struct-copy conn-state s [outbound (struct-copy buffer b [data remaining-data] [seqn ackn])] [syn-acked? (or (conn-state-syn-acked? s) @@ -448,10 +447,8 @@ ;; ^ can only send SYN until SYN is acked pending-byte-count)) (define segment-offset (if (conn-state-syn-acked? s) 0 1)) - (define-values (chunk0 remaining-data) - (bit-string-split-at (buffer-data b) (* segment-size 8))) ;; bit offset! - (define-values (discarded-dummy-syn-data chunk) - (bit-string-split-at chunk0 (* segment-offset 8))) ;; bit offset! + (define chunk0 (bit-string-take (buffer-data b) (* segment-size 8))) ;; bit offset! + (define chunk (bit-string-drop chunk0 (* segment-offset 8))) ;; bit offset! (define ackn (next-expected-seqn s)) (define flags (set)) (when ackn From 3130b307b52bb59ce2deffbaa1effadf1b8838ec Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 17 Jun 2014 19:56:52 -0400 Subject: [PATCH 14/70] Don't advertise a statevector's existence to upper layers until it is somewhat established --- tcp.rkt | 47 +++++++++++++++++++++++++++-------------------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index e897ea4..c234d24 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -375,14 +375,20 @@ ;; ConnState -> Gestalt (define (compute-gestalt s) + (define worldward-facing-gestalt + (gestalt-union (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?)) + (pub (tcp-packet #f dst-ip dst-port src-ip src-port ? ? ? ? ? ?)))) + (define appward-facing-gestalt + (if (conn-state-syn-acked? s) + (gestalt-union (if (not (buffer-finished? (conn-state-inbound s))) + (pub (tcp-channel src dst ?)) + (gestalt-empty)) + (sub (tcp-channel dst src ?)) + (pub (tcp-channel src dst ?) #:level 1)) + (gestalt-empty))) (gestalt-union (sub (timer-expired (timer-name ?) ?)) - (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?)) - (pub (tcp-packet #f dst-ip dst-port src-ip src-port ? ? ? ? ? ?)) - (sub (tcp-channel dst src ?)) - (if (not (buffer-finished? (conn-state-inbound s))) - (pub (tcp-channel src dst ?)) - (gestalt-empty)) - (pub (tcp-channel src dst ?) #:level 1))) + worldward-facing-gestalt + appward-facing-gestalt)) ;; ConnState -> Transition (define (deliver-inbound-locally s) @@ -411,19 +417,20 @@ ;; Boolean SeqNum -> ConnState -> Transition (define ((discard-acknowledged-outbound ack? ackn) s) - (transition - (if (not ack?) - s - (let* ((b (conn-state-outbound s)) - (limit (seq+ (buffer-seqn b) (bit-string-byte-count (buffer-data b)))) - (ackn (if (seq> ackn limit) limit ackn)) - (dist (seq- ackn (buffer-seqn b)))) - (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset! - (struct-copy conn-state s - [outbound (struct-copy buffer b [data remaining-data] [seqn ackn])] - [syn-acked? (or (conn-state-syn-acked? s) - (positive? dist))]))) - '())) + (if (not ack?) + (transition s '()) + (let* ((b (conn-state-outbound s)) + (limit (seq+ (buffer-seqn b) (bit-string-byte-count (buffer-data b)))) + (ackn (if (seq> ackn limit) limit ackn)) + (dist (seq- ackn (buffer-seqn b)))) + (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset! + (define new-s (struct-copy conn-state s + [outbound (struct-copy buffer b [data remaining-data] [seqn ackn])] + [syn-acked? (or (conn-state-syn-acked? s) + (positive? dist))])) + (transition new-s + (when (and (not (conn-state-syn-acked? s)) (positive? dist)) + (routing-update (compute-gestalt new-s))))))) ;; Nat -> ConnState -> Transition (define ((update-outbound-window peer-window) s) From 25c970902d177f976ce76aaa832a3b3539b9cfa2 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 17 Jun 2014 21:50:39 -0400 Subject: [PATCH 15/70] Avoid mistaking a compiled for an uncompiled projection --- tcp.rkt | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index c234d24..62d9716 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -70,10 +70,10 @@ (struct port-allocator-state (used-ports local-ips) #:transparent) (define (spawn-port-allocator) - (define port-projector - (compile-gestalt-projection (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?))) - (define ip-projector - (compile-gestalt-projection (ip-interface (?!) ?))) + (define port-projection (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?)) + (define port-compproj (compile-gestalt-projection port-projection)) + (define ip-projection (ip-interface (?!) ?)) + (define ip-compproj (compile-gestalt-projection ip-projection)) ;; TODO: Choose a sensible IP address for the outbound connection. ;; We don't have enough information to do this well at the moment, @@ -90,8 +90,8 @@ (spawn (lambda (e s) (match e [(routing-update g) - (define extracted-ips (matcher-key-set (gestalt-project g 0 0 #t ip-projector))) - (define extracted-ports (matcher-key-set (gestalt-project g 0 0 #f port-projector))) + (define extracted-ips (matcher-key-set (gestalt-project g 0 0 #t ip-compproj))) + (define extracted-ports (matcher-key-set (gestalt-project g 0 0 #f port-compproj))) (if (or (not extracted-ports) (not extracted-ips)) (error 'tcp "Someone has published a wildcard TCP address or IP interface") (transition (let ((local-ips (for/set [(e (in-set extracted-ips))] (car e)))) @@ -117,8 +117,8 @@ [_ #f])) (port-allocator-state (set) (set)) (gestalt-union (sub (tcp-port-allocation-request ? ?)) - (sub (projection->pattern ip-projector) #:level 1) - (pub (projection->pattern port-projector) #:level 1)))) + (sub (projection->pattern ip-projection) #:level 1) + (pub (projection->pattern port-projection) #:level 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Relay between kernel-level and user-level From e76fa1527c2d433610b3b8a08214a721f4b9dd87 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 18 Jun 2014 21:24:47 -0400 Subject: [PATCH 16/70] (Less im)Proper routing. --- arp.rkt | 104 +++++++---- configuration.rkt | 15 ++ ethernet.rkt | 29 ++- ip.rkt | 446 ++++++++++++++++++++++++++++------------------ main.rkt | 38 ++-- tcp.rkt | 70 ++++---- 6 files changed, 437 insertions(+), 265 deletions(-) create mode 100644 configuration.rkt diff --git a/arp.rkt b/arp.rkt index 40f5f0f..f3071a7 100644 --- a/arp.rkt +++ b/arp.rkt @@ -4,6 +4,7 @@ (provide (struct-out arp-query) (struct-out arp-assertion) + (struct-out arp-interface) spawn-arp-driver) (require racket/set) @@ -14,10 +15,12 @@ (require bitsyntax) (require "dump-bytes.rkt") +(require "configuration.rkt") (require "ethernet.rkt") -(struct arp-query (protocol protocol-address hardware-address) #:prefab) -(struct arp-assertion (protocol protocol-address) #:prefab) +(struct arp-query (protocol protocol-address interface link-address) #:prefab) +(struct arp-assertion (protocol protocol-address interface-name) #:prefab) +(struct arp-interface (interface-name) #:prefab) (define ARP-ethertype #x0806) (define cache-entry-lifetime-msec (* 14400 1000)) @@ -25,12 +28,31 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (spawn-arp-driver) + (spawn-demand-matcher (arp-interface (?!)) + #:supply-level 1 + spawn-arp-interface)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (struct cache-key (protocol address) #:transparent) -(struct cache-value (expiry address) #:transparent) +(struct cache-value (expiry interface address) #:transparent) -(struct state (hwaddr cache queries assertions) #:transparent) +(struct state (cache queries assertions) #:transparent) + +(define (spawn-arp-interface interface-name) + (log-info "spawn-arp-interface ~v" interface-name) + (lookup-ethernet-hwaddr (gestalt-for-supply interface-name) + interface-name + (lambda (hwaddr) (spawn-arp-interface* interface-name hwaddr)))) + +(define (gestalt-for-supply interface-name) + (sub (arp-interface interface-name) #:level 1)) + +(define (spawn-arp-interface* interface-name hwaddr) + (log-info "spawn-arp-interface* ~v ~v" interface-name hwaddr) + (define interface (ethernet-interface interface-name hwaddr)) -(define (spawn-arp-driver interface-name) (define (expire-cache cache) (define now (current-inexact-milliseconds)) (define (not-expired? v) (< now (cache-value-expiry v))) @@ -47,11 +69,13 @@ (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) + (gestalt-for-supply interface-name) + (sub (arp-assertion ? ? interface-name) #:level 1) + (pub (arp-query ? ? interface ?) #: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-interface v) (cache-value-address v))))))) (define (build-packet s dest-mac ptype oper sender-ha sender-pa target-ha target-pa) @@ -67,9 +91,9 @@ (sender-pa :: binary bytes plen) (target-ha :: binary bytes hlen) (target-pa :: binary bytes plen)))) - (ethernet-packet (ethernet-interface interface-name (state-hwaddr s)) + (ethernet-packet interface #f - (state-hwaddr s) + hwaddr dest-mac ARP-ethertype packet)) @@ -84,15 +108,24 @@ (sender-hardware-address0 :: binary bytes hlen) (sender-protocol-address0 :: binary bytes plen) (target-hardware-address0 :: binary bytes hlen) - (target-protocol-address0 :: binary bytes plen) ] + (target-protocol-address0 :: binary bytes plen) + (:: binary) ;; TODO: are the extra zeros coming from the + ;; router real, or an artifact of my + ;; packet-capture implementation? + ] (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)) + ;; (log-info "~a ARP Adding ~a = ~a to cache" + ;; interface-name + ;; (pretty-bytes sender-protocol-address) + ;; (pretty-bytes sender-hardware-address)) (define cache (hash-set (expire-cache (state-cache s)) (cache-key ptype sender-protocol-address) (cache-value (+ (current-inexact-milliseconds) cache-entry-lifetime-msec) + interface sender-hardware-address))) (transition (struct-copy state s [cache cache]) @@ -105,7 +138,7 @@ sender-hardware-address ptype 2 ;; reply - (state-hwaddr s) + hwaddr target-protocol-address sender-hardware-address sender-protocol-address)) @@ -115,29 +148,25 @@ (routing-update (compute-gestalt cache)))))) (else #f))) - (define queries-projection (compile-gestalt-projection (arp-query (?!) (?!) ?))) + (define queries-projection (project-subs #:level 1 (arp-query (?!) (?!) ? ?))) (define (gestalt->queries g) - (for/set [(e (in-set (matcher-key-set (gestalt-project g 0 1 #f queries-projection))))] + (for/set [(e (in-set (gestalt-project/keys g queries-projection)))] (match-define (list ptype pa) e) (cache-key ptype pa))) - (define assertions-projection (compile-gestalt-projection (arp-assertion (?!) (?!)))) + (define assertions-projection (project-pubs (arp-assertion (?!) (?!) ?))) (define (gestalt->assertions g) - (for/set [(e (matcher-key-set (gestalt-project g 0 0 #t assertions-projection)))] + (for/set [(e (in-set (gestalt-project/keys g 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 new-s (struct-copy state s [queries new-queries] [assertions new-assertions])) (define (some-asserted-pa ptype) (match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (set->list new-assertions)) @@ -152,9 +181,12 @@ ;; (log-info "analyze-gestalt: new-s ~v" new-s) (transition new-s (list + (when (gestalt-empty? (gestalt-filter g (gestalt-for-supply interface-name))) + (quit)) (for/list [(q (in-set unanswered-queries))] (define pa (some-asserted-pa (cache-key-protocol q))) - (log-info "Asking for ~a from ~a" + (log-info "~a ARP Asking for ~a from ~a" + interface-name (pretty-bytes (cache-key-address q)) (and pa (pretty-bytes pa))) (if pa @@ -167,23 +199,23 @@ 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)))))))) + (for/list [(a (in-set added-assertions))] + (log-info "~a ARP Announcing ~a as ~a" + interface-name + (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) + ;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s) (match e [(routing-update g) (analyze-gestalt g s)] @@ -196,5 +228,5 @@ (list (set-wakeup-alarm) (routing-update (compute-gestalt (state-cache new-s)))))] [_ #f])) - (state #f (hash) (set) (set)) + (state (hash) (set) (set)) (compute-gestalt (hash))))) diff --git a/configuration.rkt b/configuration.rkt new file mode 100644 index 0000000..abc4431 --- /dev/null +++ b/configuration.rkt @@ -0,0 +1,15 @@ +#lang racket/base + +(provide (struct-out ethernet-interface) + (struct-out host-route) + (struct-out net-route)) + +(struct ethernet-interface (name hwaddr) #:prefab) + +;; A Route is one of +;; - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route +;; - (net-route NetAddrBytes NetmaskNat IpAddrBytes), a gateway route for a subnet +;; - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet +;; NetmaskNat in a net-route is a default route. +(struct host-route (ip-addr netmask interface-name) #:prefab) +(struct net-route (network-addr netmask link) #:prefab) diff --git a/ethernet.rkt b/ethernet.rkt index c3b6da9..8ae6da1 100644 --- a/ethernet.rkt +++ b/ethernet.rkt @@ -1,14 +1,15 @@ #lang racket/base ;; Ethernet driver -(provide (struct-out ethernet-interface) - (struct-out ethernet-packet) +(provide (struct-out ethernet-packet) zero-ethernet-address broadcast-ethernet-address interface-names spawn-ethernet-driver + ethernet-hwaddr-projection gestalt->hwaddr - ethernet-packet-pattern) + ethernet-packet-pattern + lookup-ethernet-hwaddr) (require racket/set) (require racket/match) @@ -20,9 +21,9 @@ (require packet-socket) (require bitsyntax) +(require "configuration.rkt") (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)) @@ -50,6 +51,7 @@ (spawn (lambda (e h) (match e [(routing-update g) + (if (gestalt-empty? g) (begin (async-channel-put control-ch 'quit) (transition #f (quit))) @@ -118,12 +120,11 @@ (ethertype :: integer bytes 2) (body :: binary)))) -(define (hwaddr-projection interface-name) - (compile-gestalt-projection (ethernet-packet (ethernet-interface interface-name (?!)) ? ? ? ? ?))) +(define (ethernet-hwaddr-projection interface-name) + (project-pubs (ethernet-packet (ethernet-interface interface-name (?!)) #t ? ? ? ?))) (define (gestalt->hwaddr g interface-name) - (define hwaddrs - (matcher-key-set/single (gestalt-project g 0 0 #t (hwaddr-projection interface-name)))) + (define hwaddrs (gestalt-project/single g (ethernet-hwaddr-projection interface-name))) (case (set-count hwaddrs) [(0) #f] [(1) (set-first hwaddrs)] @@ -133,3 +134,15 @@ (define (ethernet-packet-pattern interface-name from-wire? ethertype) (ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?)) + +(define (lookup-ethernet-hwaddr base-gestalt interface-name k) + (on-gestalt #:timeout-msec 5000 + #:on-timeout (lambda () + (log-info "Lookup of ethernet interface ~v failed" interface-name) + '()) + (lambda (_g hwaddrss) + (and (not (set-empty? hwaddrss)) + (let ((hwaddr (car (set-first hwaddrss)))) + (k hwaddr)))) + base-gestalt + (ethernet-hwaddr-projection interface-name))) diff --git a/ip.rkt b/ip.rkt index bd565a5..2f7d999 100644 --- a/ip.rkt +++ b/ip.rkt @@ -1,8 +1,11 @@ #lang racket/base (provide (struct-out ip-packet) - (struct-out ip-interface) ip-address->hostname + apply-netmask + ip-address-in-subnet? + gestalt->local-ip-addresses + observe-local-ip-addresses-gestalt broadcast-ip-address spawn-ip-driver) @@ -14,12 +17,208 @@ (require bitsyntax) (require "dump-bytes.rkt") +(require "configuration.rkt") (require "checksum.rkt") (require "ethernet.rkt") (require "arp.rkt") -(struct ip-packet (source destination protocol options body) #:prefab) ;; TODO: more fields -(struct ip-interface (address ethernet) #:prefab) +(struct ip-packet (source-interface ;; string for an ethernet interface, or #f for local interfaces + source + destination + protocol + options + body) + #:prefab) ;; TODO: more fields + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (ip-address->hostname bs) + (bit-string-case bs + ([ a b c d ] (format "~a.~a.~a.~a" a b c d)))) + +(define (apply-netmask addr netmask) + (bit-string-case addr + ([ (n :: integer bytes 4) ] + (bit-string ((bitwise-and n (arithmetic-shift #x-100000000 (- netmask))) + :: integer bytes 4))))) + +(define (ip-address-in-subnet? addr network netmask) + (equal? (apply-netmask network netmask) + (apply-netmask addr netmask))) + +(define broadcast-ip-address (bytes 255 255 255 255)) + +(define local-ip-address-projector (project-pubs (host-route (?!) ? ?))) +(define (gestalt->local-ip-addresses g) (gestalt-project/single g local-ip-address-projector)) +(define observe-local-ip-addresses-gestalt (sub (host-route ? ? ?) #:level 2)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (spawn-ip-driver) + (list + (spawn-demand-matcher (host-route (?!) (?!) (?!)) + #:supply-level 1 + spawn-host-route) + (spawn-demand-matcher (net-route (?!) (?!) (?!)) + #:supply-level 1 + spawn-net-route))) + +(define (host-route-supply ip-addr netmask interface-name) + (sub (host-route ip-addr netmask interface-name) #:level 1)) + +(define (net-route-supply network-addr netmask link) + (sub (net-route network-addr netmask link) #:level 1)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Local IP route + +(define (spawn-host-route my-address netmask interface-name) + (list + (let ((network-addr (apply-netmask my-address netmask))) + (spawn-normal-ip-route (host-route-supply my-address netmask interface-name) + network-addr + netmask + interface-name)) + (spawn (lambda (e s) + (match e + [(routing-update g) + (transition s (when (gestalt-empty? g) (quit)))] + [(message (ip-packet _ peer-address _ _ _ body) _ _) + (bit-string-case body + ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum + (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 #f + my-address + peer-address + 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 ? ?)) + (pub (arp-assertion IPv4-ethertype my-address interface-name)) + (host-route-supply my-address netmask interface-name))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gateway IP route + +(define (spawn-net-route network-addr netmask link) + (cond + [(bytes? link) (spawn-gateway-ip-route network-addr netmask link)] + [(string? link) (spawn-normal-ip-route (net-route-supply network-addr netmask link) + network-addr + netmask + link)] + [else (error 'ip "Invalid net-route: ~v ~v ~v" network-addr netmask link)])) + +(define (spawn-gateway-ip-route network netmask gateway-addr) + (lookup-arp gateway-addr + ? + (net-route-supply network netmask gateway-addr) + (lambda (interface gateway-hwaddr) + (spawn-gateway-ip-route* network netmask gateway-addr interface gateway-hwaddr)))) + +(define (spawn-gateway-ip-route* network netmask gateway-addr interface gateway-hwaddr) + (define host-route-projector (project-subs (host-route (?!) ? ?))) + (define net-route-projector (project-subs (net-route (?!) (?!) ?))) + + (define (covered-by-some-other-route? addr routes) + (for/or ([r (in-set routes)]) + (match-define (list net msk) r) + (and (positive? msk) + (ip-address-in-subnet? addr net msk)))) + + (spawn (lambda (e routes) + (match e + [(routing-update g) + (define host-ips (gestalt-project/single g host-route-projector)) + (define net-ips+netmasks (gestalt-project/keys g net-route-projector)) + (transition (set-union (for/set ([ip host-ips]) (list ip 32)) net-ips+netmasks) + (when (gestalt-empty? (gestalt-filter g (net-route-supply network + netmask + gateway-addr))) + (quit)))] + [(message (? ip-packet? p) _ _) + (and (not (equal? (ip-packet-source-interface p) (ethernet-interface-name interface))) + (not (covered-by-some-other-route? (ip-packet-destination p) routes)) + (transition routes + (send (ethernet-packet interface + #f + (ethernet-interface-hwaddr interface) + gateway-hwaddr + IPv4-ethertype + (format-ip-packet p)))))] + [_ #f])) + (set) + (gestalt-union (if (zero? netmask) + (net-route-supply network netmask gateway-addr) + (gestalt-empty)) + observe-local-ip-addresses-gestalt + (sub (ip-packet ? ? ? ? ? ?)) + (pub (ip-packet ? ? ? ? ? ?))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Normal IP route + +(define (spawn-normal-ip-route gestalt-for-supply network netmask interface-name) + (spawn (lambda (e s) + (match e + [(routing-update g) + (log-info "normal-ip route ~v/~v/~v quitting:\n~a" + network + netmask + interface-name + (gestalt->pretty-string g)) + (transition s (when (gestalt-empty? g) (quit)))] + [(message (ethernet-packet _ _ _ _ _ body) _ _) + (define p (parse-ip-packet interface-name body)) + (and p (transition s (send p)))] + [(message (? ip-packet? p) _ _) + (define destination (ip-packet-destination p)) + (and (not (equal? (ip-packet-source-interface p) interface-name)) + (ip-address-in-subnet? destination network netmask) + (transition + s + (lookup-arp destination + (ethernet-interface interface-name ?) + (gestalt-empty) + (lambda (interface destination-hwaddr) + (send (ethernet-packet interface + #f + (ethernet-interface-hwaddr interface) + destination-hwaddr + IPv4-ethertype + (format-ip-packet p)))))))] + [_ #f])) + (void) + (gestalt-union gestalt-for-supply + (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)) + (pub (arp-interface interface-name)) + (sub (ip-packet ? ? ? ? ? ?)) + (pub (ip-packet ? ? ? ? ? ?))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define IPv4-ethertype #x0800) @@ -32,174 +231,83 @@ (define default-ttl 64) -(define (ip-address->hostname bs) - (bit-string-case bs - ([ a b c d ] (format "~a.~a.~a.~a" a b c d)))) +(define (parse-ip-packet interface-name body) + ;; (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) ;; TODO: check checksum + (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 (>= header-length 5) + (>= (bit-string-byte-count body) (* header-length 4))) + (bit-string-case rest + ([ (opts :: binary bytes options-length) + (data :: binary) ] + (ip-packet interface-name + (bit-string->bytes source-ip) + (bit-string->bytes destination-ip) + protocol + (bit-string->bytes opts) + (bit-string->bytes data)))) + #f))) + (else #f))) -(define broadcast-ip-address (bytes 255 255 255 255)) +(define (format-ip-packet p) + (match-define (ip-packet _ src dst protocol options body) p) -(struct state (hwaddr) #:transparent) + (define header-length ;; TODO: ensure options is a multiple of 4 bytes + (+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4))) -(define (spawn-ip-driver interface-name my-address) + (define header0 (bit-string (IP-VERSION :: bits 4) + (header-length :: bits 4) + 0 ;; TODO: service type + ((+ (* header-length 4) (bit-string-byte-count body)) + :: bits 16) + (0 :: bits 16) ;; TODO: identifier + (0 :: bits 3) ;; TODO: flags + (0 :: bits 13) ;; TODO: fragments + default-ttl + protocol + (0 :: bits 16) + (src :: binary bits 32) + (dst :: binary bits 32) + (options :: binary))) + (define full-packet (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary))) - (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) ;; TODO: check checksum - (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-byte-count 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) - protocol - (bit-string->bytes opts) - (bit-string->bytes data)))))) - #f))) - (else #f))) + full-packet) - (define (analyze-gestalt g s) - (define hwaddr (gestalt->hwaddr g interface-name)) - (define new-s (struct-copy state s [hwaddr hwaddr])) - (transition new-s (routing-update (compute-gestalt new-s)))) - - (define (compute-gestalt s) - (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 ? ? ? ?)) - (pub (ip-packet ? my-address ? ? ?)) - (if (state-hwaddr s) - (pub (ip-interface my-address (ethernet-interface interface-name (state-hwaddr s)))) - (gestalt-empty)))) - - (list - (spawn-icmp-driver my-address) - (let ((state0 (state #f))) - (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 protocol options body) _ _) - (define header-length ;; TODO: ensure options is a multiple of 4 bytes - (+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4))) - (define header0 - (bit-string (IP-VERSION :: bits 4) - (header-length :: bits 4) - 0 ;; TODO: service type - ((+ (* header-length 4) (bit-string-byte-count body)) - :: bits 16) - (0 :: bits 16) ;; TODO: identifier - (0 :: bits 3) ;; TODO: flags - (0 :: bits 13) ;; TODO: fragments - default-ttl - protocol - (0 :: bits 16) - (my-address :: binary bits 32) - (peer-address :: binary bits 32) - (options :: binary))) - (define full-packet (bit-string ((ip-checksum 10 header0) :: binary) - (body :: binary))) - (transition s (spawn-packet-sender interface-name - (state-hwaddr s) - peer-address - full-packet))] - [_ #f])) - state0 - (compute-gestalt state0))))) - -(define arp-result-projection (compile-gestalt-projection (arp-query ? ? (?!)))) - -(define (spawn-packet-sender interface-name local-hwaddr remote-ip full-packet) - (define timer-id (list (gensym 'packet) remote-ip)) - (list - (send (set-timer timer-id 5000 'relative)) - (spawn (lambda (e s) - (match e - [(routing-update g) - (define all-results - (matcher-key-set/single (gestalt-project g 0 0 #t arp-result-projection))) - (match all-results - [#f (error 'ip "Someone has published a wildcard arp result")] - [(? set-empty?) #f] ;; no results yet, keep waiting - [_ - (define remote-hwaddr (set-first all-results)) - (unless (= 1 (set-count all-results)) - (log-warning "Ambiguous arp result for ~a: ~v" - (ip-address->hostname remote-ip) - all-results)) - (transition s - (list - (send (ethernet-packet (ethernet-interface interface-name - local-hwaddr) - #f - local-hwaddr - remote-hwaddr - IPv4-ethertype - full-packet)) - (quit)))])] - [(message (timer-expired _ _) _ _) - (log-warning "ARP lookup failed, packet dropped") - (transition s (quit))] - [_ #f])) - (void) - (gestalt-union (sub (timer-expired timer-id ?)) - (sub (arp-query IPv4-ethertype remote-ip ?) #:level 1))))) - -(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) ] ;; TODO: check cksum - (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 - 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 ? ?))))) +(define (lookup-arp ipaddr query-interface-pattern base-gestalt k) + (on-gestalt (lambda (_g arp-results) + (if (not arp-results) + (error 'ip "Someone has published a wildcard arp result") + (and (not (set-empty? arp-results)) + (match (set-first arp-results) + [(list interface hwaddr) + (log-info "ARP lookup yielded ~a on ~a for ~a" + (pretty-bytes hwaddr) + (ethernet-interface-name interface) + (ip-address->hostname ipaddr)) + (when (> (set-count arp-results) 1) + (log-warning "Ambiguous ARP result for ~a: ~v" + (ip-address->hostname ipaddr) + arp-results)) + (k interface hwaddr)])))) + base-gestalt + (project-pubs (arp-query IPv4-ethertype ipaddr (?! query-interface-pattern) (?!))) + #:timeout-msec 5000 + #:on-timeout (lambda () + (log-warning "ARP lookup of ~a failed, packet dropped" + (ip-address->hostname ipaddr)) + '()))) diff --git a/main.rkt b/main.rkt index fb6d194..ff4fd5c 100644 --- a/main.rkt +++ b/main.rkt @@ -2,28 +2,35 @@ (require minimart/demand-matcher) (require minimart/drivers/timer) +(require "configuration.rkt") (require "ethernet.rkt") (require "arp.rkt") (require "ip.rkt") (require "tcp.rkt") -(define interface "vboxnet0") - ;;(log-events-and-actions? #t) (spawn-timer-driver) (spawn-ethernet-driver) -(spawn-arp-driver interface) -(spawn-ip-driver interface (bytes 192 168 56 222)) +(spawn-arp-driver) +(spawn-ip-driver) (spawn-tcp-driver) +(spawn (lambda (e s) #f) + (void) + (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) + (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) + (pub (net-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (let () (local-require racket/set racket/string) (define (spawn-session them us) (define user (gensym 'user)) - (define remote-detector (compile-gestalt-projection (?!))) - (define peer-detector (compile-gestalt-projection `(,(?!) says ,?))) + (define remote-detector (project-pubs #:meta-level 1 (?!))) + (define peer-detector (project-pubs `(,(?!) says ,?))) (define (send-to-remote fmt . vs) (send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) (define (say who fmt . vs) @@ -38,12 +45,10 @@ [(message `(,who says ,what) 0 #f) (transition old-peers (say who "says: ~a" what))] [(routing-update g) - (define new-peers - (matcher-key-set/single (gestalt-project g 0 0 #t peer-detector))) + (define new-peers (gestalt-project/single g peer-detector)) (transition new-peers - (list (when (matcher-empty? (gestalt-project g 1 0 #t remote-detector)) - (quit)) + (list (when (matcher-empty? (gestalt-project g remote-detector)) (quit)) (for/list [(who (set-subtract new-peers old-peers))] (say who "arrived.")) (for/list [(who (set-subtract old-peers new-peers))] @@ -68,15 +73,18 @@ (local-require racket/pretty) (match e [(message m _ _) - (pretty-write `(MAIN ,m))] + ;; (pretty-write `(MAIN ,m)) + (void)] [(routing-update g) - (printf "MAIN gestalt:\n") - (pretty-print-gestalt g)] + ;; (printf "MAIN gestalt:\n") + ;; (pretty-print-gestalt g) + (void)] [_ (void)]) (flush-output) #f) (void) (gestalt-union - ;;(sub ? #:level 5) - (sub (tcp-channel ? ? ?) #:level 5) + (sub ? #:level 5) + (pub ? #:level 5) + ;;(sub (tcp-channel ? ? ?) #:level 5) )) diff --git a/tcp.rkt b/tcp.rkt index 62d9716..0bbfe34 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -70,10 +70,8 @@ (struct port-allocator-state (used-ports local-ips) #:transparent) (define (spawn-port-allocator) - (define port-projection (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?)) - (define port-compproj (compile-gestalt-projection port-projection)) - (define ip-projection (ip-interface (?!) ?)) - (define ip-compproj (compile-gestalt-projection ip-projection)) + (define port-projection + (project-subs (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?))) ;; TODO: Choose a sensible IP address for the outbound connection. ;; We don't have enough information to do this well at the moment, @@ -90,18 +88,17 @@ (spawn (lambda (e s) (match e [(routing-update g) - (define extracted-ips (matcher-key-set (gestalt-project g 0 0 #t ip-compproj))) - (define extracted-ports (matcher-key-set (gestalt-project g 0 0 #f port-compproj))) - (if (or (not extracted-ports) (not extracted-ips)) + (define local-ips (gestalt->local-ip-addresses g)) + (define extracted-ports (gestalt-project/keys g port-projection)) + (if (or (not extracted-ports) (not local-ips)) (error 'tcp "Someone has published a wildcard TCP address or IP interface") - (transition (let ((local-ips (for/set [(e (in-set extracted-ips))] (car e)))) - (port-allocator-state - (for/fold [(s (set))] [(e (in-set extracted-ports))] - (match-define (list si sp di dp) e) - (let* ((s (if (set-member? local-ips si) (set-add s sp) s)) - (s (if (set-member? local-ips di) (set-add s dp) s))) - s)) - local-ips)) + (transition (port-allocator-state + (for/fold [(s (set))] [(e (in-set extracted-ports))] + (match-define (list si sp di dp) e) + (let* ((s (if (set-member? local-ips si) (set-add s sp) s)) + (s (if (set-member? local-ips di) (set-add s dp) s))) + s)) + local-ips) '()))] [(message (tcp-port-allocation-request local-addr remote-addr) _ _) (define currently-used-ports (port-allocator-state-used-ports s)) @@ -117,8 +114,8 @@ [_ #f])) (port-allocator-state (set) (set)) (gestalt-union (sub (tcp-port-allocation-request ? ?)) - (sub (projection->pattern ip-projection) #:level 1) - (pub (projection->pattern port-projection) #:level 1)))) + observe-local-ip-addresses-gestalt + (pub (tcp-channel (tcp-address ? ?) (tcp-address ? ?) ?) #:level 1)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Relay between kernel-level and user-level @@ -159,17 +156,12 @@ (define PROTOCOL-TCP 6) -(struct codec-state (active-state-vectors) #:transparent) +(struct codec-state (local-ips active-state-vectors) #:transparent) (define (spawn-kernel-tcp-driver) - (define (flip-statevec statevec) - (match-define (list si sp di dp) statevec) - (list di dp si sp)) - (define (state-vector-active? statevec s) - (or (set-member? (codec-state-active-state-vectors s) statevec) - (set-member? (codec-state-active-state-vectors s) (flip-statevec statevec)))) + (set-member? (codec-state-active-state-vectors s) statevec)) (define (analyze-incoming-packet src-ip dst-ip body s) (bit-string-case body @@ -237,14 +229,15 @@ (else #f)))) (else #f))) - (define statevec-projection - (compile-gestalt-projection - (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?))) + (define statevec-projection (project-subs (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?))) (define (analyze-gestalt g s) - (define statevecs (matcher-key-set (gestalt-project g 0 0 #f statevec-projection))) - (log-info "gestalt yielded statevecs ~v" statevecs) - (transition (struct-copy codec-state s [active-state-vectors statevecs]) '())) + (define local-ips (gestalt->local-ip-addresses g)) + (define statevecs (gestalt-project/keys g statevec-projection)) + (log-info "gestalt yielded statevecs ~v and local-ips ~v" statevecs local-ips) + (transition (struct-copy codec-state s + [local-ips local-ips] + [active-state-vectors statevecs]) '())) (define (deliver-outbound-packet p s) (match-define (tcp-packet #f @@ -294,26 +287,29 @@ 0 PROTOCOL-TCP ((bit-string-byte-count payload) :: integer bytes 2))) - (transition s (send (ip-packet src-ip dst-ip PROTOCOL-TCP #"" + (transition s (send (ip-packet #f src-ip dst-ip PROTOCOL-TCP #"" (ip-checksum 16 payload #:pseudo-header pseudo-header))))) (spawn (lambda (e s) + (log-info "xxxxx TCP ~v" e) (match e [(routing-update g) (analyze-gestalt g s)] - [(message (ip-packet src dst _ _ body) _ _) + [(message (ip-packet source-if src dst _ _ body) _ _) + #:when (and source-if ;; source-if == #f iff packet originates locally + (set-member? (codec-state-local-ips s) dst)) (analyze-incoming-packet src dst body s)] [(message (? tcp-packet? p) _ _) #:when (not (tcp-packet-from-wire? p)) (deliver-outbound-packet p s)] [_ #f])) - (codec-state (set)) - (gestalt-union (pub (ip-packet ? ? PROTOCOL-TCP ? ?)) - (sub (ip-packet ? ? PROTOCOL-TCP ? ?)) + (codec-state (set) (set)) + (gestalt-union (pub (ip-packet #f ? ? PROTOCOL-TCP ? ?)) + (sub (ip-packet ? ? ? PROTOCOL-TCP ? ?)) (sub (tcp-packet #f ? ? ? ? ? ? ? ? ? ?)) (pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?)) - (pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?) - #:level 1)))) + (pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?) #:level 1) + observe-local-ip-addresses-gestalt))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Per-connection state vector process From a2eeb6d5e4613a91043dd2a41699060f30759611 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 18 Jun 2014 22:13:58 -0400 Subject: [PATCH 17/70] Default to port 6667 instead of 5999 --- main.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.rkt b/main.rkt index ff4fd5c..bb01384 100644 --- a/main.rkt +++ b/main.rkt @@ -63,7 +63,7 @@ (pub (tcp-channel us them ?) #:meta-level 1))))) (spawn-world - (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 5999)) ?) + (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 6667)) ?) #:meta-level 1 spawn-session)) From 42850e20ef11e8435bc9987eb2d19f5b62898947 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 18 Jun 2014 23:58:09 -0400 Subject: [PATCH 18/70] Omit debug output --- tcp.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/tcp.rkt b/tcp.rkt index 0bbfe34..e2b9bd8 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -291,7 +291,6 @@ (ip-checksum 16 payload #:pseudo-header pseudo-header))))) (spawn (lambda (e s) - (log-info "xxxxx TCP ~v" e) (match e [(routing-update g) (analyze-gestalt g s)] From f5ce8cd93fe7744b8b2b431da194ca318ea5044d Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 18 Jun 2014 23:58:25 -0400 Subject: [PATCH 19/70] Handle ethernet short packet padding by applying IPv4 total packet length. --- arp.rkt | 7 ++++--- ip.rkt | 10 ++++++---- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/arp.rkt b/arp.rkt index f3071a7..a6ab180 100644 --- a/arp.rkt +++ b/arp.rkt @@ -109,9 +109,10 @@ (sender-protocol-address0 :: binary bytes plen) (target-hardware-address0 :: binary bytes hlen) (target-protocol-address0 :: binary bytes plen) - (:: binary) ;; TODO: are the extra zeros coming from the - ;; router real, or an artifact of my - ;; packet-capture implementation? + (:: binary) ;; The extra zeros exist because ethernet packets + ;; have a minimum size. This is, in part, why + ;; IPv4 headers have a total-length field, so + ;; that the zero padding can be removed. ] (let () (define sender-protocol-address (bit-string->bytes sender-protocol-address0)) diff --git a/ip.rkt b/ip.rkt index 2f7d999..452662a 100644 --- a/ip.rkt +++ b/ip.rkt @@ -247,14 +247,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)))) + (let* ((source-ip (bit-string->bytes source-ip0)) + (destination-ip (bit-string->bytes destination-ip0)) + (options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH))) + (data-length (- total-length (* 4 header-length)))) (if (and (>= header-length 5) (>= (bit-string-byte-count body) (* header-length 4))) (bit-string-case rest ([ (opts :: binary bytes options-length) - (data :: binary) ] + (data :: binary bytes data-length) + (:: binary) ] ;; Very short ethernet packets have a trailer of zeros (ip-packet interface-name (bit-string->bytes source-ip) (bit-string->bytes destination-ip) From 1fb6935d811678f31c5cf4ce567cce5feb94f2ad Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 18 Jun 2014 23:59:57 -0400 Subject: [PATCH 20/70] Omit misleading debug output --- ip.rkt | 5 ----- 1 file changed, 5 deletions(-) diff --git a/ip.rkt b/ip.rkt index 452662a..8591d5e 100644 --- a/ip.rkt +++ b/ip.rkt @@ -183,11 +183,6 @@ (spawn (lambda (e s) (match e [(routing-update g) - (log-info "normal-ip route ~v/~v/~v quitting:\n~a" - network - netmask - interface-name - (gestalt->pretty-string g)) (transition s (when (gestalt-empty? g) (quit)))] [(message (ethernet-packet _ _ _ _ _ body) _ _) (define p (parse-ip-packet interface-name body)) From 61c59250ee5996a8d3d606ca41c2b5fc133d37cc Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 18:00:37 -0400 Subject: [PATCH 21/70] UDP driver --- ip.rkt | 7 +- main.rkt | 14 ++++ port-allocator.rkt | 46 +++++++++++++ tcp.rkt | 77 ++++++--------------- udp.rkt | 164 +++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 251 insertions(+), 57 deletions(-) create mode 100644 port-allocator.rkt create mode 100644 udp.rkt diff --git a/ip.rkt b/ip.rkt index 8591d5e..fa3ffb4 100644 --- a/ip.rkt +++ b/ip.rkt @@ -2,6 +2,7 @@ (provide (struct-out ip-packet) ip-address->hostname + ip-string->ip-address apply-netmask ip-address-in-subnet? gestalt->local-ip-addresses @@ -11,6 +12,7 @@ (require racket/set) (require racket/match) +(require (only-in racket/string string-split)) (require minimart) (require minimart/drivers/timer) (require minimart/demand-matcher) @@ -36,6 +38,9 @@ (bit-string-case bs ([ a b c d ] (format "~a.~a.~a.~a" a b c d)))) +(define (ip-string->ip-address str) + (list->bytes (map string->number (string-split str ".")))) + (define (apply-netmask addr netmask) (bit-string-case addr ([ (n :: integer bytes 4) ] @@ -221,8 +226,6 @@ (define IP-MINIMUM-HEADER-LENGTH 5) (define PROTOCOL-ICMP 1) -;; (define PROTOCOL-TCP 6) -;; (define PROTOCOL-UDP 17) (define default-ttl 64) diff --git a/main.rkt b/main.rkt index bb01384..1831169 100644 --- a/main.rkt +++ b/main.rkt @@ -7,6 +7,7 @@ (require "arp.rkt") (require "ip.rkt") (require "tcp.rkt") +(require "udp.rkt") ;;(log-events-and-actions? #t) @@ -15,6 +16,7 @@ (spawn-arp-driver) (spawn-ip-driver) (spawn-tcp-driver) +(spawn-udp-driver) (spawn (lambda (e s) #f) (void) @@ -69,6 +71,18 @@ ) +(let () + (spawn (lambda (e s) + (match e + [(message (udp-packet src dst body) _ _) + (log-info "Got packet from ~v: ~v" src body) + (transition s (send (udp-packet dst + src + (string->bytes/utf-8 (format "You said: ~a" body)))))] + [_ #f])) + (void) + (gestalt-union (sub (udp-packet ? (udp-listener 6667) ?))))) + (spawn (lambda (e s) (local-require racket/pretty) (match e diff --git a/port-allocator.rkt b/port-allocator.rkt new file mode 100644 index 0000000..fbfed66 --- /dev/null +++ b/port-allocator.rkt @@ -0,0 +1,46 @@ +#lang racket/base +;; UDP/TCP port allocator + +(provide spawn-port-allocator + (struct-out port-allocation-request)) + +(require racket/set) +(require racket/match) +(require minimart) +(require "ip.rkt") + +(struct port-allocation-request (type k) #:prefab) + +(struct port-allocator-state (used-ports local-ips) #:transparent) + +(define (spawn-port-allocator allocator-type port-projections) + (spawn (lambda (e s) + (match e + [(routing-update g) + (define local-ips (or (gestalt->local-ip-addresses g) (set))) + (define extracted-ips+ports + (apply set-union + (set) + (map (lambda (p) (or (gestalt-project/keys g p) (set))) port-projections))) + (define new-used-ports (for/fold [(s (set))] [(e (in-set extracted-ips+ports))] + (match-define (list hostname port) e) + (if (set-member? local-ips (ip-string->ip-address hostname)) + (set-add s port) + s))) + (log-info "port-allocator ~v used ports: ~v" allocator-type new-used-ports) + (transition (port-allocator-state new-used-ports local-ips) '())] + [(message (port-allocation-request _ k) _ _) + (define currently-used-ports (port-allocator-state-used-ports s)) + (let randomly-allocate-until-unused () + (define p (+ 1024 (random 64512))) + (if (set-member? currently-used-ports p) + (randomly-allocate-until-unused) + (transition (struct-copy port-allocator-state s + [used-ports (set-add currently-used-ports p)]) + (k p (port-allocator-state-local-ips s)))))] + [_ #f])) + (port-allocator-state (set) (set)) + (apply gestalt-union + (sub (port-allocation-request allocator-type ?)) + observe-local-ip-addresses-gestalt + (map projection->gestalt port-projections)))) diff --git a/tcp.rkt b/tcp.rkt index e2b9bd8..5955717 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -16,6 +16,7 @@ (require "dump-bytes.rkt") (require "checksum.rkt") (require "ip.rkt") +(require "port-allocator.rkt") ;; tcp-address/tcp-address : "kernel" tcp connection state machines ;; tcp-handle/tcp-address : "user" outbound connections @@ -57,65 +58,31 @@ (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-address ? port)) ?) (spawn-relay server-addr)))) (spawn-demand-matcher (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?) - (lambda (local-addr remote-addr) - (send (tcp-port-allocation-request local-addr remote-addr)))) - (spawn-port-allocator) + allocate-port-and-spawn-socket) + (spawn-port-allocator 'tcp + (list (project-subs (tcp-channel (tcp-address (?!) (?!)) ? ?)) + (project-subs (tcp-channel ? (tcp-address (?!) (?!)) ?)))) (spawn-kernel-tcp-driver))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Port allocator +;; Port allocation -(struct tcp-port-allocation-request (local-addr remote-addr) #:prefab) - -(struct port-allocator-state (used-ports local-ips) #:transparent) - -(define (spawn-port-allocator) - (define port-projection - (project-subs (tcp-channel (tcp-address (?!) (?!)) (tcp-address (?!) (?!)) ?))) - - ;; TODO: Choose a sensible IP address for the outbound connection. - ;; We don't have enough information to do this well at the moment, - ;; so just pick some available local IP address. - ;; - ;; Interesting note: In some sense, the right answer is "?". This - ;; would give us a form of mobility, where IP addresses only route - ;; to a given bucket-of-state and ONLY the port number selects a - ;; substate therein. That's not how TCP is defined however so we - ;; can't do that. - (define (appropriate-ip s) - (set-first (port-allocator-state-local-ips s))) - - (spawn (lambda (e s) - (match e - [(routing-update g) - (define local-ips (gestalt->local-ip-addresses g)) - (define extracted-ports (gestalt-project/keys g port-projection)) - (if (or (not extracted-ports) (not local-ips)) - (error 'tcp "Someone has published a wildcard TCP address or IP interface") - (transition (port-allocator-state - (for/fold [(s (set))] [(e (in-set extracted-ports))] - (match-define (list si sp di dp) e) - (let* ((s (if (set-member? local-ips si) (set-add s sp) s)) - (s (if (set-member? local-ips di) (set-add s dp) s))) - s)) - local-ips) - '()))] - [(message (tcp-port-allocation-request local-addr remote-addr) _ _) - (define currently-used-ports (port-allocator-state-used-ports s)) - (let randomly-allocate-until-unused () - (define p (+ 1024 (random 64512))) - (if (set-member? currently-used-ports p) - (randomly-allocate-until-unused) - (transition (struct-copy port-allocator-state s - [used-ports (set-add currently-used-ports p)]) - ((spawn-relay local-addr) - remote-addr - (tcp-channel (appropriate-ip s) p)))))] - [_ #f])) - (port-allocator-state (set) (set)) - (gestalt-union (sub (tcp-port-allocation-request ? ?)) - observe-local-ip-addresses-gestalt - (pub (tcp-channel (tcp-address ? ?) (tcp-address ? ?) ?) #:level 1)))) +(define (allocate-port-and-spawn-socket local-addr remote-addr) + (send (port-allocation-request + 'tcp + (lambda (port local-ips) + ;; TODO: Choose a sensible IP address for the outbound + ;; connection. We don't have enough information to do this + ;; well at the moment, so just pick some available local IP + ;; address. + ;; + ;; Interesting note: In some sense, the right answer is + ;; "?". This would give us a form of mobility, where IP + ;; addresses only route to a given bucket-of-state and ONLY + ;; the port number selects a substate therein. That's not + ;; how TCP is defined however so we can't do that. + (define appropriate-ip (set-first local-ips)) + ((spawn-relay local-addr) remote-addr (tcp-channel appropriate-ip port)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Relay between kernel-level and user-level diff --git a/udp.rkt b/udp.rkt new file mode 100644 index 0000000..b51f3bf --- /dev/null +++ b/udp.rkt @@ -0,0 +1,164 @@ +#lang racket/base + +(provide (struct-out udp-remote-address) + (struct-out udp-handle) + (struct-out udp-listener) + udp-address? + udp-local-address? + (struct-out udp-packet) + spawn-udp-driver) + +(require racket/set) +(require racket/match) +(require minimart) +(require minimart/demand-matcher) +(require bitsyntax) + +(require "dump-bytes.rkt") +(require "checksum.rkt") +(require "ip.rkt") +(require "port-allocator.rkt") + +;; udp-address/udp-address : "kernel" udp connection state machines +;; udp-handle/udp-address : "user" outbound connections +;; udp-listener/udp-address : "user" inbound connections + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Protocol messages + +(struct udp-remote-address (host port) #:prefab) +(struct udp-handle (id) #:prefab) +(struct udp-listener (port) #:prefab) + +(define (udp-address? x) + (or (udp-remote-address? x) + (udp-local-address? x))) + +(define (udp-local-address? x) + (or (udp-handle? x) + (udp-listener? x))) + +(struct udp-packet (source destination body) #:prefab) + +(define any-remote (udp-remote-address ? ?)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; User-accessible driver startup + +(define (spawn-udp-driver) + (list + (spawn-demand-matcher (udp-packet ? (?! (udp-listener ?)) ?) + #:demand-is-subscription? #t + (lambda (handle) (spawn-udp-relay (udp-listener-port handle) handle))) + (spawn-demand-matcher (udp-packet ? (?! (udp-handle ?)) ?) + #:demand-is-subscription? #t + (lambda (handle) + (send (port-allocation-request + 'udp + (lambda (port local-ips) (spawn-udp-relay port handle)))))) + (spawn-port-allocator 'udp + (list (project-subs (udp-packet (udp-remote-address (?!) (?!)) ? ?)) + (project-subs (udp-packet ? (udp-remote-address (?!) (?!)) ?)))) + (spawn-kernel-udp-driver))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Relaying + +(define (spawn-udp-relay local-port local-user-addr) + (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr) + + (define local-peer-gestalt (pub (udp-packet any-remote local-user-addr ?) #:level 1)) + + (define (compute-gestalt local-ips) + (for/fold [(g (gestalt-union local-peer-gestalt + observe-local-ip-addresses-gestalt + (pub (udp-packet any-remote local-user-addr ?)) + (sub (udp-packet local-user-addr any-remote ?))))] + [(ip (in-set local-ips))] + (define hostname (ip-address->hostname ip)) + (define local-network-addr (udp-remote-address hostname local-port)) + (gestalt-union g + (sub (udp-packet any-remote local-network-addr ?)) + (pub (udp-packet local-network-addr any-remote ?))))) + + (spawn (lambda (e local-ips) + (log-info "RELAY ~v" e) + (match e + [(routing-update g) + (define new-local-ips (gestalt->local-ip-addresses g)) + (log-info "Updating relay gestalt:\n~a" (gestalt->pretty-string (compute-gestalt new-local-ips))) + (transition new-local-ips + (list + (when (gestalt-empty? (gestalt-filter g local-peer-gestalt)) (quit)) + (routing-update (compute-gestalt new-local-ips))))] + [(message (udp-packet (== local-user-addr) remote-addr bs) _ _) + ;; Choose arbitrary local IP address for outbound packet! + ;; TODO: what can be done? Must I examine the routing table? + (define local-network-addr + (udp-remote-address (ip-address->hostname (set-first local-ips)) local-port)) + (transition local-ips (send (udp-packet local-network-addr remote-addr bs)))] + [(message (udp-packet remote-addr (udp-remote-address _ _) bs) _ _) + (transition local-ips (send (udp-packet remote-addr local-user-addr bs)))] + [_ #f])) + (set) + (compute-gestalt (set)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Codec & kernel-level driver + +(define PROTOCOL-UDP 17) + +(define (spawn-kernel-udp-driver) + (spawn (lambda (e local-ips) + (match e + [(routing-update g) + (transition (gestalt->local-ip-addresses g) '())] + [(message (ip-packet source-if src-ip dst-ip _ _ body) _ _) + #:when (and source-if (set-member? local-ips dst-ip)) + (define src-host (ip-address->hostname src-ip)) + (define dst-host (ip-address->hostname dst-ip)) + (bit-string-case body + ([ (src-port :: integer bytes 2) + (dst-port :: integer bytes 2) + (length :: integer bytes 2) + (checksum :: integer bytes 2) ;; TODO: check checksum + (data :: binary) ] + (bit-string-case data + ([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes + (:: binary) ] + (transition local-ips (send (udp-packet (udp-remote-address src-host src-port) + (udp-remote-address dst-host dst-port) + (bit-string->bytes payload))))) + (else #f))) + (else #f))] + [(message (udp-packet (udp-remote-address sh sp) (udp-remote-address dh dp) bs) _ _) + (define src-ip (ip-string->ip-address sh)) + (define dst-ip (ip-string->ip-address dh)) + (and (set-member? local-ips src-ip) + (let* ((payload (bit-string (sp :: integer bytes 2) + (dp :: integer bytes 2) + ((+ 8 (bit-string-byte-count bs)) + :: integer bytes 2) + (0 :: integer bytes 2) ;; checksum location + (bs :: binary))) + (pseudo-header (bit-string (src-ip :: binary bytes 4) + (dst-ip :: binary bytes 4) + 0 + PROTOCOL-UDP + ((bit-string-byte-count payload) + :: integer bytes 2))) + (checksummed-payload (ip-checksum #:pseudo-header pseudo-header + 6 payload))) + (transition local-ips (send (ip-packet #f + src-ip + dst-ip + PROTOCOL-UDP + #"" + checksummed-payload)))))] + [_ #f])) + (set) + (gestalt-union (pub (ip-packet #f ? ? PROTOCOL-UDP ? ?)) + (sub (ip-packet ? ? ? PROTOCOL-UDP ? ?)) + (sub (udp-packet any-remote any-remote ?)) + (pub (udp-packet any-remote any-remote ?)) + observe-local-ip-addresses-gestalt))) From 39b19ba624e0b2f69bec56164e2aca9f19d1362f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 21:56:30 -0400 Subject: [PATCH 22/70] Reask ARP questions periodically until we get answers or stop caring. --- arp.rkt | 93 +++++++++++++++++++++++++++++---------------------------- 1 file changed, 47 insertions(+), 46 deletions(-) diff --git a/arp.rkt b/arp.rkt index a6ab180..1b0cff6 100644 --- a/arp.rkt +++ b/arp.rkt @@ -78,7 +78,7 @@ (cache-value-interface v) (cache-value-address v))))))) - (define (build-packet s dest-mac ptype oper sender-ha sender-pa target-ha target-pa) + (define (build-packet 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 @@ -118,12 +118,19 @@ (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)) - ;; (log-info "~a ARP Adding ~a = ~a to cache" - ;; interface-name - ;; (pretty-bytes sender-protocol-address) - ;; (pretty-bytes sender-hardware-address)) + (define learned-key (cache-key ptype sender-protocol-address)) + (when (and (set-member? (state-queries s) learned-key) ;; it is relevant to our interests + (not (equal? sender-hardware-address + (cache-value-address (hash-ref (state-cache s) + learned-key + (lambda () + (cache-value #f #f #f))))))) + (log-info "~a ARP Adding ~a = ~a to cache" + interface-name + (pretty-bytes sender-protocol-address) + (pretty-bytes sender-hardware-address))) (define cache (hash-set (expire-cache (state-cache s)) - (cache-key ptype sender-protocol-address) + learned-key (cache-value (+ (current-inexact-milliseconds) cache-entry-lifetime-msec) interface @@ -135,8 +142,7 @@ [(1) ;; request (if (set-member? (state-assertions s) (cache-key ptype target-protocol-address)) - (send (build-packet s - sender-hardware-address + (send (build-packet sender-hardware-address ptype 2 ;; reply hwaddr @@ -162,51 +168,19 @@ (cache-key ptype pa))) (define (analyze-gestalt g s) - (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 [queries new-queries] [assertions new-assertions])) - (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) + (define new-s (struct-copy state s [queries (gestalt->queries g)] [assertions new-assertions])) (transition new-s (list (when (gestalt-empty? (gestalt-filter g (gestalt-for-supply interface-name))) (quit)) - (for/list [(q (in-set unanswered-queries))] - (define pa (some-asserted-pa (cache-key-protocol q))) - (log-info "~a ARP Asking for ~a from ~a" - interface-name - (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))) - '())) (for/list [(a (in-set added-assertions))] (log-info "~a ARP Announcing ~a as ~a" interface-name (pretty-bytes (cache-key-address a)) (pretty-bytes hwaddr)) - (send (build-packet new-s - broadcast-ethernet-address + (send (build-packet broadcast-ethernet-address (cache-key-protocol a) 2 ;; reply -- gratuitous announcement hwaddr @@ -214,20 +188,47 @@ hwaddr (cache-key-address a))))))) + (define (send-questions s) + (define unanswered-queries + (set-subtract (state-queries s) (list->set (hash-keys (state-cache s))))) + (define (some-asserted-pa ptype) + (match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) + (set->list (state-assertions s))) + ['() #f] + [(list* k _) (cache-key-address k)])) + (transition s + (for/list [(q (in-set unanswered-queries))] + (define pa (some-asserted-pa (cache-key-protocol q))) + (log-info "~a ARP Asking for ~a from ~a" + interface-name + (pretty-bytes (cache-key-address q)) + (and pa (pretty-bytes pa))) + (when pa + (send (build-packet broadcast-ethernet-address + (cache-key-protocol q) + 1 ;; request + hwaddr + pa + zero-ethernet-address + (cache-key-address q))))))) + (list (set-wakeup-alarm) (spawn (lambda (e s) ;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s) (match e [(routing-update g) - (analyze-gestalt g s)] + (sequence-transitions (analyze-gestalt g s) + send-questions)] [(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)))))] + (define new-g (compute-gestalt (state-cache new-s))) + (sequence-transitions (transition new-s + (list (set-wakeup-alarm) + (routing-update new-g))) + send-questions)] [_ #f])) (state (hash) (set) (set)) (compute-gestalt (hash))))) From d063b3b2fb993c2cc548fd1853f504c4a642e9e6 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 21:57:51 -0400 Subject: [PATCH 23/70] Track changes in gateway hwaddr --- ip.rkt | 52 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 33 insertions(+), 19 deletions(-) diff --git a/ip.rkt b/ip.rkt index fa3ffb4..8168fc7 100644 --- a/ip.rkt +++ b/ip.rkt @@ -124,7 +124,7 @@ (host-route-supply my-address netmask interface-name))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Gateway IP route +;; General net route (define (spawn-net-route network-addr netmask link) (cond @@ -135,16 +135,15 @@ link)] [else (error 'ip "Invalid net-route: ~v ~v ~v" network-addr netmask link)])) -(define (spawn-gateway-ip-route network netmask gateway-addr) - (lookup-arp gateway-addr - ? - (net-route-supply network netmask gateway-addr) - (lambda (interface gateway-hwaddr) - (spawn-gateway-ip-route* network netmask gateway-addr interface gateway-hwaddr)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Gateway IP route -(define (spawn-gateway-ip-route* network netmask gateway-addr interface gateway-hwaddr) +(struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent) + +(define (spawn-gateway-ip-route network netmask gateway-addr) (define host-route-projector (project-subs (host-route (?!) ? ?))) (define net-route-projector (project-subs (net-route (?!) (?!) ?))) + (define gateway-arp-projector (project-pubs (arp-query IPv4-ethertype gateway-addr (?!) (?!)))) (define (covered-by-some-other-route? addr routes) (for/or ([r (in-set routes)]) @@ -152,34 +151,49 @@ (and (positive? msk) (ip-address-in-subnet? addr net msk)))) - (spawn (lambda (e routes) + (spawn (lambda (e s) (match e [(routing-update g) (define host-ips (gestalt-project/single g host-route-projector)) (define net-ips+netmasks (gestalt-project/keys g net-route-projector)) - (transition (set-union (for/set ([ip host-ips]) (list ip 32)) net-ips+netmasks) + (define gw-ip+hwaddr (let ((vs (gestalt-project/keys g gateway-arp-projector))) + (and vs (not (set-empty? vs)) (set-first vs)))) + (transition (gateway-route-state + (set-union (for/set ([ip host-ips]) (list ip 32)) net-ips+netmasks) + (and gw-ip+hwaddr (car gw-ip+hwaddr)) + (and gw-ip+hwaddr (cadr gw-ip+hwaddr))) (when (gestalt-empty? (gestalt-filter g (net-route-supply network netmask gateway-addr))) (quit)))] [(message (? ip-packet? p) _ _) - (and (not (equal? (ip-packet-source-interface p) (ethernet-interface-name interface))) - (not (covered-by-some-other-route? (ip-packet-destination p) routes)) - (transition routes - (send (ethernet-packet interface + (define gw-if (gateway-route-state-gateway-interface s)) + (when (not gw-if) + (log-warning "Gateway hwaddr for ~a not known, packet dropped" + (ip-address->hostname gateway-addr))) + (and gw-if + (not (equal? (ip-packet-source-interface p) (ethernet-interface-name gw-if))) + (not (covered-by-some-other-route? (ip-packet-destination p) + (gateway-route-state-routes s))) + (transition s + (send (ethernet-packet gw-if #f - (ethernet-interface-hwaddr interface) - gateway-hwaddr + (ethernet-interface-hwaddr gw-if) + (gateway-route-state-gateway-hwaddr s) IPv4-ethertype (format-ip-packet p)))))] [_ #f])) - (set) + (gateway-route-state (set) #f #f) (gestalt-union (if (zero? netmask) (net-route-supply network netmask gateway-addr) (gestalt-empty)) - observe-local-ip-addresses-gestalt + (sub (ip-packet ? ? ? ? ? ?)) - (pub (ip-packet ? ? ? ? ? ?))))) + (pub (ip-packet ? ? ? ? ? ?)) + + observe-local-ip-addresses-gestalt + (sub (net-route ? ? ?) #:level 2) + (projection->gestalt gateway-arp-projector)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Normal IP route From 90c8e8555bd2afc68d1a8f9519a2a98c8da136e9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 22:16:53 -0400 Subject: [PATCH 24/70] Generalize port-allocator --- port-allocator.rkt | 14 +++----------- tcp.rkt | 19 +++++++++++++++---- 2 files changed, 18 insertions(+), 15 deletions(-) diff --git a/port-allocator.rkt b/port-allocator.rkt index fbfed66..f175961 100644 --- a/port-allocator.rkt +++ b/port-allocator.rkt @@ -13,20 +13,12 @@ (struct port-allocator-state (used-ports local-ips) #:transparent) -(define (spawn-port-allocator allocator-type port-projections) +(define (spawn-port-allocator allocator-type projections compute-used-ports) (spawn (lambda (e s) (match e [(routing-update g) (define local-ips (or (gestalt->local-ip-addresses g) (set))) - (define extracted-ips+ports - (apply set-union - (set) - (map (lambda (p) (or (gestalt-project/keys g p) (set))) port-projections))) - (define new-used-ports (for/fold [(s (set))] [(e (in-set extracted-ips+ports))] - (match-define (list hostname port) e) - (if (set-member? local-ips (ip-string->ip-address hostname)) - (set-add s port) - s))) + (define new-used-ports (compute-used-ports g local-ips)) (log-info "port-allocator ~v used ports: ~v" allocator-type new-used-ports) (transition (port-allocator-state new-used-ports local-ips) '())] [(message (port-allocation-request _ k) _ _) @@ -43,4 +35,4 @@ (apply gestalt-union (sub (port-allocation-request allocator-type ?)) observe-local-ip-addresses-gestalt - (map projection->gestalt port-projections)))) + (map projection->gestalt projections)))) diff --git a/tcp.rkt b/tcp.rkt index 5955717..fb311e3 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -54,19 +54,31 @@ #:supply-level 2 (lambda (server-addr) (match-define (tcp-listener port) server-addr) + ;; TODO: have listener shut down once user-level listener does (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-address ? port)) ?) (spawn-relay server-addr)))) (spawn-demand-matcher (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?) allocate-port-and-spawn-socket) - (spawn-port-allocator 'tcp - (list (project-subs (tcp-channel (tcp-address (?!) (?!)) ? ?)) - (project-subs (tcp-channel ? (tcp-address (?!) (?!)) ?)))) + (spawn-tcp-port-allocator) (spawn-kernel-tcp-driver))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Port allocation +(define (spawn-tcp-port-allocator) + (define project-active-connections (project-pubs (tcp-packet #f (?!) (?!) ? ? ? ? ? ? ? ?))) + (define project-listeners (project-subs #:level 1 (tcp-channel ? (tcp-listener (?!)) ?))) + (spawn-port-allocator 'tcp + (list project-active-connections project-listeners) + (lambda (g local-ips) + (define listener-ports (gestalt-project/single g project-listeners)) + (define active-connection-ports + (for/set [(e (gestalt-project/keys g project-active-connections)) + #:when (set-member? local-ips (car e))] + (cadr e))) + (set-union listener-ports active-connection-ports)))) + (define (allocate-port-and-spawn-socket local-addr remote-addr) (send (port-allocation-request 'tcp @@ -273,7 +285,6 @@ (gestalt-union (pub (ip-packet #f ? ? PROTOCOL-TCP ? ?)) (sub (ip-packet ? ? ? PROTOCOL-TCP ? ?)) (sub (tcp-packet #f ? ? ? ? ? ? ? ? ? ?)) - (pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?)) (pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?) #:level 1) observe-local-ip-addresses-gestalt))) From ae9887b8fb7e6edb947621fd25265e66b8af717c Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 22:17:23 -0400 Subject: [PATCH 25/70] Remove debug output --- tcp.rkt | 7 ------- 1 file changed, 7 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index fb311e3..6f1965f 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -103,13 +103,6 @@ (define local-peer-traffic (pub (tcp-channel remote-addr local-user-addr ?) #:level 1)) (define remote-peer-traffic (sub (tcp-channel remote-addr local-tcp-addr ?) #:level 1)) (spawn (lambda (e seen-local-peer?) - (local-require racket/pretty) - (pretty-write `(RELAY (local-user-addr ,local-user-addr) - (remote-addr ,remote-addr) - (local-tcp-addr ,local-tcp-addr) - (seen-local-peer? ,seen-local-peer?) - (e ,e))) - (flush-output) (match e [(routing-update g) (define local-peer-absent? (gestalt-empty? (gestalt-filter g local-peer-traffic))) From 191a71ec801f643dcf5c4e1f1b834fb1916ab6d7 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 22:18:04 -0400 Subject: [PATCH 26/70] Better protocol separation between user and kernel layers of UDP --- udp.rkt | 101 +++++++++++++++++++++++++++++++------------------------- 1 file changed, 56 insertions(+), 45 deletions(-) diff --git a/udp.rkt b/udp.rkt index b51f3bf..4841c68 100644 --- a/udp.rkt +++ b/udp.rkt @@ -38,8 +38,12 @@ (or (udp-handle? x) (udp-listener? x))) +;; USER-level protocol (struct udp-packet (source destination body) #:prefab) +;; KERNEL-level protocol +(struct udp-datagram (source-ip source-port destination-ip destination-port body) #:prefab) + (define any-remote (udp-remote-address ? ?)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -56,11 +60,18 @@ (send (port-allocation-request 'udp (lambda (port local-ips) (spawn-udp-relay port handle)))))) - (spawn-port-allocator 'udp - (list (project-subs (udp-packet (udp-remote-address (?!) (?!)) ? ?)) - (project-subs (udp-packet ? (udp-remote-address (?!) (?!)) ?)))) + (spawn-udp-port-allocator) (spawn-kernel-udp-driver))) +(define (spawn-udp-port-allocator) + (define udp-projector (project-pubs (udp-datagram (?!) (?!) ? ? ?))) + (spawn-port-allocator 'udp + (list udp-projector) + (lambda (g local-ips) + (for/set [(e (gestalt-project/keys g udp-projector)) + #:when (set-member? local-ips (car e))] + (cadr e))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Relaying @@ -75,18 +86,14 @@ (pub (udp-packet any-remote local-user-addr ?)) (sub (udp-packet local-user-addr any-remote ?))))] [(ip (in-set local-ips))] - (define hostname (ip-address->hostname ip)) - (define local-network-addr (udp-remote-address hostname local-port)) (gestalt-union g - (sub (udp-packet any-remote local-network-addr ?)) - (pub (udp-packet local-network-addr any-remote ?))))) + (sub (udp-datagram ? ? ip local-port ?)) + (pub (udp-datagram ip local-port ? ? ?))))) (spawn (lambda (e local-ips) - (log-info "RELAY ~v" e) (match e [(routing-update g) (define new-local-ips (gestalt->local-ip-addresses g)) - (log-info "Updating relay gestalt:\n~a" (gestalt->pretty-string (compute-gestalt new-local-ips))) (transition new-local-ips (list (when (gestalt-empty? (gestalt-filter g local-peer-gestalt)) (quit)) @@ -94,11 +101,18 @@ [(message (udp-packet (== local-user-addr) remote-addr bs) _ _) ;; Choose arbitrary local IP address for outbound packet! ;; TODO: what can be done? Must I examine the routing table? - (define local-network-addr - (udp-remote-address (ip-address->hostname (set-first local-ips)) local-port)) - (transition local-ips (send (udp-packet local-network-addr remote-addr bs)))] - [(message (udp-packet remote-addr (udp-remote-address _ _) bs) _ _) - (transition local-ips (send (udp-packet remote-addr local-user-addr bs)))] + (match-define (udp-remote-address remote-host remote-port) remote-addr) + (define remote-ip (ip-string->ip-address remote-host)) + (transition local-ips (send (udp-datagram (set-first local-ips) + local-port + remote-ip + remote-port + bs)))] + [(message (udp-datagram si sp _ _ bs) _ _) + (transition local-ips (send (udp-packet (udp-remote-address (ip-address->hostname si) + sp) + local-user-addr + bs)))] [_ #f])) (set) (compute-gestalt (set)))) @@ -115,8 +129,6 @@ (transition (gestalt->local-ip-addresses g) '())] [(message (ip-packet source-if src-ip dst-ip _ _ body) _ _) #:when (and source-if (set-member? local-ips dst-ip)) - (define src-host (ip-address->hostname src-ip)) - (define dst-host (ip-address->hostname dst-ip)) (bit-string-case body ([ (src-port :: integer bytes 2) (dst-port :: integer bytes 2) @@ -126,39 +138,38 @@ (bit-string-case data ([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes (:: binary) ] - (transition local-ips (send (udp-packet (udp-remote-address src-host src-port) - (udp-remote-address dst-host dst-port) - (bit-string->bytes payload))))) + (transition local-ips (send (udp-datagram src-ip + src-port + dst-ip + dst-port + (bit-string->bytes payload))))) (else #f))) (else #f))] - [(message (udp-packet (udp-remote-address sh sp) (udp-remote-address dh dp) bs) _ _) - (define src-ip (ip-string->ip-address sh)) - (define dst-ip (ip-string->ip-address dh)) - (and (set-member? local-ips src-ip) - (let* ((payload (bit-string (sp :: integer bytes 2) - (dp :: integer bytes 2) - ((+ 8 (bit-string-byte-count bs)) - :: integer bytes 2) - (0 :: integer bytes 2) ;; checksum location - (bs :: binary))) - (pseudo-header (bit-string (src-ip :: binary bytes 4) - (dst-ip :: binary bytes 4) - 0 - PROTOCOL-UDP - ((bit-string-byte-count payload) - :: integer bytes 2))) - (checksummed-payload (ip-checksum #:pseudo-header pseudo-header - 6 payload))) - (transition local-ips (send (ip-packet #f - src-ip - dst-ip - PROTOCOL-UDP - #"" - checksummed-payload)))))] + [(message (udp-datagram src-ip src-port dst-ip dst-port bs) _ _) + #:when (set-member? local-ips src-ip) + (let* ((payload (bit-string (src-port :: integer bytes 2) + (dst-port :: integer bytes 2) + ((+ 8 (bit-string-byte-count bs)) + :: integer bytes 2) + (0 :: integer bytes 2) ;; checksum location + (bs :: binary))) + (pseudo-header (bit-string (src-ip :: binary bytes 4) + (dst-ip :: binary bytes 4) + 0 + PROTOCOL-UDP + ((bit-string-byte-count payload) + :: integer bytes 2))) + (checksummed-payload (ip-checksum #:pseudo-header pseudo-header + 6 payload))) + (transition local-ips (send (ip-packet #f + src-ip + dst-ip + PROTOCOL-UDP + #"" + checksummed-payload))))] [_ #f])) (set) (gestalt-union (pub (ip-packet #f ? ? PROTOCOL-UDP ? ?)) (sub (ip-packet ? ? ? PROTOCOL-UDP ? ?)) - (sub (udp-packet any-remote any-remote ?)) - (pub (udp-packet any-remote any-remote ?)) + (sub (udp-datagram ? ? ? ? ?)) observe-local-ip-addresses-gestalt))) From 33a60e4a0245707bc86b72fe56530b89b50a05ce Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 22:27:19 -0400 Subject: [PATCH 27/70] We have to be more careful about observing at level 3 while projecting at level 1 --- port-allocator.rkt | 4 ++-- tcp.rkt | 11 ++++++++--- udp.rkt | 2 +- 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/port-allocator.rkt b/port-allocator.rkt index f175961..6466db3 100644 --- a/port-allocator.rkt +++ b/port-allocator.rkt @@ -13,7 +13,7 @@ (struct port-allocator-state (used-ports local-ips) #:transparent) -(define (spawn-port-allocator allocator-type projections compute-used-ports) +(define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports) (spawn (lambda (e s) (match e [(routing-update g) @@ -35,4 +35,4 @@ (apply gestalt-union (sub (port-allocation-request allocator-type ?)) observe-local-ip-addresses-gestalt - (map projection->gestalt projections)))) + observer-gestalt))) diff --git a/tcp.rkt b/tcp.rkt index 6f1965f..86e3359 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -68,11 +68,16 @@ (define (spawn-tcp-port-allocator) (define project-active-connections (project-pubs (tcp-packet #f (?!) (?!) ? ? ? ? ? ? ? ?))) - (define project-listeners (project-subs #:level 1 (tcp-channel ? (tcp-listener (?!)) ?))) + ;; We have to have gestalt observing listeners at level 3 so that + ;; we're not mistaken for listener supply! We still project out at + ;; level 1 (instead of level 2, as would be natural for a level 3 + ;; observer gestalt) though. + (define listeners-p (project-subs #:level 1 (tcp-channel ? (tcp-listener (?!)) ?))) + (define listeners-g (pub #:level 3 (tcp-channel ? (tcp-listener ?) ?))) (spawn-port-allocator 'tcp - (list project-active-connections project-listeners) + (list (projection->gestalt project-active-connections) listeners-g) (lambda (g local-ips) - (define listener-ports (gestalt-project/single g project-listeners)) + (define listener-ports (gestalt-project/single g listeners-p)) (define active-connection-ports (for/set [(e (gestalt-project/keys g project-active-connections)) #:when (set-member? local-ips (car e))] diff --git a/udp.rkt b/udp.rkt index 4841c68..a2444c5 100644 --- a/udp.rkt +++ b/udp.rkt @@ -66,7 +66,7 @@ (define (spawn-udp-port-allocator) (define udp-projector (project-pubs (udp-datagram (?!) (?!) ? ? ?))) (spawn-port-allocator 'udp - (list udp-projector) + (list (projection->gestalt udp-projector)) (lambda (g local-ips) (for/set [(e (gestalt-project/keys g udp-projector)) #:when (set-member? local-ips (car e))] From 93b1b0fcf3c1a1d2dd3d35b10aa80f59df77cf60 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 22:36:14 -0400 Subject: [PATCH 28/70] Convenient default routing tables per host --- main.rkt | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/main.rkt b/main.rkt index 1831169..b1896f5 100644 --- a/main.rkt +++ b/main.rkt @@ -2,6 +2,7 @@ (require minimart/demand-matcher) (require minimart/drivers/timer) +(require (only-in mzlib/os gethostname)) (require "configuration.rkt") (require "ethernet.rkt") (require "arp.rkt") @@ -20,9 +21,16 @@ (spawn (lambda (e s) #f) (void) - (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) - (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) - (pub (net-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1))))) + (match (gethostname) + ["hop" + (gestalt-union (pub (net-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1))) + (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] + ["stockholm.ccs.neu.edu" + (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) + (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) + (pub (net-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1))))] + [else + (error 'stack-configuration "No setup for hostname ~a" (gethostname))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From ea9660d83db0ad0448e1038b3b29b670fb1444c2 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 23:10:50 -0400 Subject: [PATCH 29/70] Be more explicit about gateway routes having specific interfaces, to avoid ARP reqs on the wrong interface. --- configuration.rkt | 4 +++- ip.rkt | 61 ++++++++++++++++++++++++++++------------------- main.rkt | 4 ++-- 3 files changed, 41 insertions(+), 28 deletions(-) diff --git a/configuration.rkt b/configuration.rkt index abc4431..665320c 100644 --- a/configuration.rkt +++ b/configuration.rkt @@ -2,14 +2,16 @@ (provide (struct-out ethernet-interface) (struct-out host-route) + (struct-out gateway-route) (struct-out net-route)) (struct ethernet-interface (name hwaddr) #:prefab) ;; A Route is one of ;; - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route -;; - (net-route NetAddrBytes NetmaskNat IpAddrBytes), a gateway route for a subnet +;; - (gateway-route NetAddrBytes NetmaskNat IpAddrBytes InterfaceName), a gateway for a subnet ;; - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet ;; NetmaskNat in a net-route is a default route. (struct host-route (ip-addr netmask interface-name) #:prefab) +(struct gateway-route (network-addr netmask gateway-addr interface-name) #:prefab) (struct net-route (network-addr netmask link) #:prefab) diff --git a/ip.rkt b/ip.rkt index 8168fc7..a8f9ab5 100644 --- a/ip.rkt +++ b/ip.rkt @@ -64,6 +64,9 @@ (spawn-demand-matcher (host-route (?!) (?!) (?!)) #:supply-level 1 spawn-host-route) + (spawn-demand-matcher (gateway-route (?!) (?!) (?!) (?!)) + #:supply-level 1 + spawn-gateway-route) (spawn-demand-matcher (net-route (?!) (?!) (?!)) #:supply-level 1 spawn-net-route))) @@ -71,6 +74,9 @@ (define (host-route-supply ip-addr netmask interface-name) (sub (host-route ip-addr netmask interface-name) #:level 1)) +(define (gateway-route-supply network-addr netmask gateway-addr interface-name) + (sub (gateway-route network-addr netmask gateway-addr interface-name) #:level 1)) + (define (net-route-supply network-addr netmask link) (sub (net-route network-addr netmask link) #:level 1)) @@ -123,27 +129,21 @@ (pub (arp-assertion IPv4-ethertype my-address interface-name)) (host-route-supply my-address netmask interface-name))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; General net route - -(define (spawn-net-route network-addr netmask link) - (cond - [(bytes? link) (spawn-gateway-ip-route network-addr netmask link)] - [(string? link) (spawn-normal-ip-route (net-route-supply network-addr netmask link) - network-addr - netmask - link)] - [else (error 'ip "Invalid net-route: ~v ~v ~v" network-addr netmask link)])) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Gateway IP route (struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent) -(define (spawn-gateway-ip-route network netmask gateway-addr) +(define (spawn-gateway-route network netmask gateway-addr interface-name) + (define gestalt-for-supply (gateway-route-supply network netmask gateway-addr interface-name)) + (define host-route-projector (project-subs (host-route (?!) ? ?))) + (define gateway-route-projector (project-subs (gateway-route (?!) (?!) ? ?))) (define net-route-projector (project-subs (net-route (?!) (?!) ?))) - (define gateway-arp-projector (project-pubs (arp-query IPv4-ethertype gateway-addr (?!) (?!)))) + (define gateway-arp-projector (project-pubs (arp-query IPv4-ethertype + gateway-addr + (?! (ethernet-interface interface-name ?)) + (?!)))) (define (covered-by-some-other-route? addr routes) (for/or ([r (in-set routes)]) @@ -155,22 +155,28 @@ (match e [(routing-update g) (define host-ips (gestalt-project/single g host-route-projector)) - (define net-ips+netmasks (gestalt-project/keys g net-route-projector)) + (define gw-nets+netmasks (gestalt-project/keys g gateway-route-projector)) + (define net-nets+netmasks (gestalt-project/keys g net-route-projector)) (define gw-ip+hwaddr (let ((vs (gestalt-project/keys g gateway-arp-projector))) (and vs (not (set-empty? vs)) (set-first vs)))) + (when (and gw-ip+hwaddr (not (gateway-route-state-gateway-hwaddr s))) + (log-info "Discovered gateway ~a at ~a on interface ~a." + (ip-address->hostname gateway-addr) + (ethernet-interface-name (car gw-ip+hwaddr)) + (pretty-bytes (cadr gw-ip+hwaddr)))) (transition (gateway-route-state - (set-union (for/set ([ip host-ips]) (list ip 32)) net-ips+netmasks) + (set-union (for/set ([ip host-ips]) (list ip 32)) + gw-nets+netmasks + net-nets+netmasks) (and gw-ip+hwaddr (car gw-ip+hwaddr)) (and gw-ip+hwaddr (cadr gw-ip+hwaddr))) - (when (gestalt-empty? (gestalt-filter g (net-route-supply network - netmask - gateway-addr))) - (quit)))] + (when (gestalt-empty? (gestalt-filter g gestalt-for-supply)) (quit)))] [(message (? ip-packet? p) _ _) (define gw-if (gateway-route-state-gateway-interface s)) (when (not gw-if) - (log-warning "Gateway hwaddr for ~a not known, packet dropped" - (ip-address->hostname gateway-addr))) + (log-warning "Gateway hwaddr for ~a not known, packet dropped: ~v" + (ip-address->hostname gateway-addr) + p)) (and gw-if (not (equal? (ip-packet-source-interface p) (ethernet-interface-name gw-if))) (not (covered-by-some-other-route? (ip-packet-destination p) @@ -184,17 +190,22 @@ (format-ip-packet p)))))] [_ #f])) (gateway-route-state (set) #f #f) - (gestalt-union (if (zero? netmask) - (net-route-supply network netmask gateway-addr) - (gestalt-empty)) + (gestalt-union gestalt-for-supply (sub (ip-packet ? ? ? ? ? ?)) (pub (ip-packet ? ? ? ? ? ?)) observe-local-ip-addresses-gestalt (sub (net-route ? ? ?) #:level 2) + (sub (gateway-route ? ? ? ?) #:level 2) (projection->gestalt gateway-arp-projector)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; General net route + +(define (spawn-net-route network-addr netmask link) + (spawn-normal-ip-route (net-route-supply network-addr netmask link) network-addr netmask link)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Normal IP route diff --git a/main.rkt b/main.rkt index b1896f5..d76871f 100644 --- a/main.rkt +++ b/main.rkt @@ -23,12 +23,12 @@ (void) (match (gethostname) ["hop" - (gestalt-union (pub (net-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1))) + (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] ["stockholm.ccs.neu.edu" (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) - (pub (net-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1))))] + (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] [else (error 'stack-configuration "No setup for hostname ~a" (gethostname))])) From 82c5ea71edb7c96c5e82f1e39d83aaed9a541787 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 19 Jun 2014 23:17:59 -0400 Subject: [PATCH 30/70] Tidy up debug output --- arp.rkt | 19 ++++++++++++------- ip.rkt | 5 ++--- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/arp.rkt b/arp.rkt index 1b0cff6..657b8b9 100644 --- a/arp.rkt +++ b/arp.rkt @@ -142,13 +142,18 @@ [(1) ;; request (if (set-member? (state-assertions s) (cache-key ptype target-protocol-address)) - (send (build-packet sender-hardware-address - ptype - 2 ;; reply - hwaddr - target-protocol-address - sender-hardware-address - sender-protocol-address)) + (begin + (log-info "~a ARP answering request for ~a/~a" + interface-name + ptype + (pretty-bytes target-protocol-address)) + (send (build-packet sender-hardware-address + ptype + 2 ;; reply + hwaddr + target-protocol-address + sender-hardware-address + sender-protocol-address))) '())] [(2) '()] ;; reply [else '()]) diff --git a/ip.rkt b/ip.rkt index a8f9ab5..8106801 100644 --- a/ip.rkt +++ b/ip.rkt @@ -174,9 +174,8 @@ [(message (? ip-packet? p) _ _) (define gw-if (gateway-route-state-gateway-interface s)) (when (not gw-if) - (log-warning "Gateway hwaddr for ~a not known, packet dropped: ~v" - (ip-address->hostname gateway-addr) - p)) + (log-warning "Gateway hwaddr for ~a not known, packet dropped." + (ip-address->hostname gateway-addr))) (and gw-if (not (equal? (ip-packet-source-interface p) (ethernet-interface-name gw-if))) (not (covered-by-some-other-route? (ip-packet-destination p) From 6a3bafe0827a6438b61392b52d280fbd9e57398f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 20 Jun 2014 00:08:43 -0400 Subject: [PATCH 31/70] RST when we're not listening on a port --- tcp.rkt | 39 +++++++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index 86e3359..f0402fc 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -299,7 +299,8 @@ inbound ;; buffer syn-acked? ;; boolean latest-activity-time ;; from current-inexact-milliseconds - local-peer-seen?) ;; boolean + local-peer-seen? ;; boolean + listener-listening?) ;; boolean #:transparent) (define transmit-check-interval-msec 100) @@ -344,19 +345,25 @@ (define (seq> a b) (< (seq- a b) #x80000000)) + (define local-peer-detector (pub (tcp-channel src dst ?) #:level 1)) + (define listener-detector (pub (tcp-channel ? (tcp-listener dst-port) ?) #:level 3)) + ;; ^ see comment in spawn-tcp-port-allocator for why level 3 instead of level 2 + ;; ConnState -> Gestalt (define (compute-gestalt s) (define worldward-facing-gestalt (gestalt-union (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?)) (pub (tcp-packet #f dst-ip dst-port src-ip src-port ? ? ? ? ? ?)))) (define appward-facing-gestalt - (if (conn-state-syn-acked? s) - (gestalt-union (if (not (buffer-finished? (conn-state-inbound s))) - (pub (tcp-channel src dst ?)) - (gestalt-empty)) - (sub (tcp-channel dst src ?)) - (pub (tcp-channel src dst ?) #:level 1)) - (gestalt-empty))) + (gestalt-union + local-peer-detector + listener-detector + (if (conn-state-syn-acked? s) + (gestalt-union (sub (tcp-channel dst src ?)) + (if (not (buffer-finished? (conn-state-inbound s))) + (pub (tcp-channel src dst ?)) + (gestalt-empty))) + (gestalt-empty)))) (gestalt-union (sub (timer-expired (timer-name ?) ?)) worldward-facing-gestalt appward-facing-gestalt)) @@ -501,7 +508,7 @@ #"")) (quit)))) - ;; ConnState -> ConnState + ;; ConnState -> Transition (define (close-outbound-stream s) (transition (struct-copy conn-state s @@ -514,21 +521,24 @@ (match e [(routing-update g) (log-info "State vector routing-update:\n~a" (gestalt->pretty-string g)) - (define local-peer-present? (not (gestalt-empty? g))) + (define local-peer-present? (not (gestalt-empty? (gestalt-filter g local-peer-detector)))) + (define listening? (not (gestalt-empty? (gestalt-filter g listener-detector)))) + (define new-s (struct-copy conn-state s [listener-listening? listening?])) (cond [(and local-peer-present? (not (conn-state-local-peer-seen? s))) - (transition (struct-copy conn-state s [local-peer-seen? #t]) '())] + (transition (struct-copy conn-state new-s [local-peer-seen? #t]) '())] [(and (not local-peer-present?) (conn-state-local-peer-seen? s)) (log-info "Closing outbound stream.") - (sequence-transitions (close-outbound-stream s) + (sequence-transitions (close-outbound-stream new-s) (send-outbound old-ackn) bump-activity-time quit-when-done)] - [else #f])] + [else (transition new-s '())])] [(message (tcp-packet #t _ _ _ _ seqn ackn flags window options data) _ _) (define expected (next-expected-seqn s)) (if (and (not expected) ;; no syn yet - (not (set-member? flags 'syn))) ;; and this isn't it + (or (not (set-member? flags 'syn)) ;; and this isn't it + (not (conn-state-listener-listening? s)))) ;; or it is, but no-one local cares (reset ackn ;; this is *our* seqn seqn ;; this is what we should acknowledge... (set-member? flags 'fin) ;; ... +1, if fin is set @@ -575,6 +585,7 @@ (buffer #"" #f inbound-buffer-limit #f) #f (current-inexact-milliseconds) + #f #f))) (spawn state-vector-behavior state0 From b497004f0beacde1664fbf4a078c45ec3f101c2f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 20 Jun 2014 00:15:31 -0400 Subject: [PATCH 32/70] Correct ack sequence number on RST responding to SYN (i.e. closed port) --- tcp.rkt | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index f0402fc..e28eb55 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -490,8 +490,8 @@ transmit-check-interval-msec 'relative))) - ;; ConnState -> Transition - (define (reset seqn ackn is-fin? s) + ;; SeqNum SeqNum ConnState -> Transition + (define (reset seqn ackn s) (log-warning "Sending RST from ~a:~a to ~a:~a" (ip-address->hostname dst-ip) dst-port @@ -501,7 +501,7 @@ (list (send (tcp-packet #f dst-ip dst-port src-ip src-port seqn - (seq+ ackn (if is-fin? 1 0)) + ackn (set 'ack 'rst) 0 #"" @@ -536,12 +536,14 @@ [else (transition new-s '())])] [(message (tcp-packet #t _ _ _ _ seqn ackn flags window options data) _ _) (define expected (next-expected-seqn s)) + (define is-syn? (set-member? flags 'syn)) + (define is-fin? (set-member? flags 'fin)) (if (and (not expected) ;; no syn yet - (or (not (set-member? flags 'syn)) ;; and this isn't it + (or (not is-syn?) ;; and this isn't it (not (conn-state-listener-listening? s)))) ;; or it is, but no-one local cares (reset ackn ;; this is *our* seqn - seqn ;; this is what we should acknowledge... - (set-member? flags 'fin) ;; ... +1, if fin is set + (seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0))) + ;; ^^ this is what we should acknowledge... s) (sequence-transitions (cond [(not expected) ;; haven't seen syn yet, but we know this is it From 034a96bcc91d1648f3514c6ed9d1e9d5ae274ff5 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 06:48:12 -0400 Subject: [PATCH 33/70] skip config --- main.rkt | 3 +++ 1 file changed, 3 insertions(+) diff --git a/main.rkt b/main.rkt index d76871f..3013dd2 100644 --- a/main.rkt +++ b/main.rkt @@ -22,6 +22,9 @@ (spawn (lambda (e s) #f) (void) (match (gethostname) + ["skip" + (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) + (pub (host-route (bytes 192 168 1 222) 24 "en0")))] ["hop" (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] From 9f9431cb29e958c88c3b3f39963ce72faaf47be0 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 06:51:06 -0400 Subject: [PATCH 34/70] Closer to correct patterns etc for outbound connections --- tcp.rkt | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/tcp.rkt b/tcp.rkt index e28eb55..febfa6a 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -99,7 +99,12 @@ ;; the port number selects a substate therein. That's not ;; how TCP is defined however so we can't do that. (define appropriate-ip (set-first local-ips)) - ((spawn-relay local-addr) remote-addr (tcp-channel appropriate-ip port)))))) + (define appropriate-host (ip-address->hostname appropriate-ip)) + (match-define (tcp-address remote-host remote-port) remote-addr) + (define remote-ip (ip-string->ip-address remote-host)) + (list + ((spawn-relay local-addr) remote-addr (tcp-address appropriate-host port)) + (spawn-state-vector remote-ip remote-port appropriate-ip port)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Relay between kernel-level and user-level From e913237f26b614e91ef1374bf327661427529e19 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 06:51:23 -0400 Subject: [PATCH 35/70] Make TCP relay pay attention to presence for both legs --- tcp.rkt | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index febfa6a..f8ad97b 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -112,20 +112,22 @@ (define ((spawn-relay local-user-addr) remote-addr local-tcp-addr) (define local-peer-traffic (pub (tcp-channel remote-addr local-user-addr ?) #:level 1)) (define remote-peer-traffic (sub (tcp-channel remote-addr local-tcp-addr ?) #:level 1)) - (spawn (lambda (e seen-local-peer?) + (spawn (lambda (e state) (match e [(routing-update g) (define local-peer-absent? (gestalt-empty? (gestalt-filter g local-peer-traffic))) - (transition (or seen-local-peer? (not local-peer-absent?)) - (when (or (and seen-local-peer? local-peer-absent?) - (gestalt-empty? (gestalt-filter g remote-peer-traffic))) - (quit)))] + (define remote-peer-absent? (gestalt-empty? (gestalt-filter g remote-peer-traffic))) + (define new-state (+ (if local-peer-absent? 0 1) (if remote-peer-absent? 0 1))) + (log-info "RELAY OLD ~v NEW ~v" state new-state) + (transition new-state (when (< new-state state) (quit)))] [(message (tcp-channel (== local-user-addr) (== remote-addr) bs) _ _) - (transition seen-local-peer? (send (tcp-channel local-tcp-addr remote-addr bs)))] + (log-info "RELAYING ~v" (tcp-channel local-tcp-addr remote-addr bs)) + (transition state (send (tcp-channel local-tcp-addr remote-addr bs)))] [(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs) _ _) - (transition seen-local-peer? (send (tcp-channel remote-addr local-user-addr bs)))] + (log-info "BACKRELAYING ~v" (tcp-channel remote-addr local-user-addr bs)) + (transition state (send (tcp-channel remote-addr local-user-addr bs)))] [_ #f])) - #f + 0 (gestalt-union local-peer-traffic remote-peer-traffic (sub (tcp-channel remote-addr local-tcp-addr ?)) From 89acb53a434a7134888039a6e646883b164eb45f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 06:51:41 -0400 Subject: [PATCH 36/70] Bump retransmit interval crudely to 2s --- tcp.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tcp.rkt b/tcp.rkt index f8ad97b..fb3698c 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -310,7 +310,7 @@ listener-listening?) ;; boolean #:transparent) -(define transmit-check-interval-msec 100) +(define transmit-check-interval-msec 2000) (define inbound-buffer-limit 65535) (define maximum-segment-size 536) ;; bytes (define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout From 0bf2033d44dda93018bafc827da87ed189d0628f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 06:52:26 -0400 Subject: [PATCH 37/70] Closer to working outbound connections --- tcp.rkt | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index fb3698c..ee42b55 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -365,11 +365,10 @@ (gestalt-union local-peer-detector listener-detector - (if (conn-state-syn-acked? s) - (gestalt-union (sub (tcp-channel dst src ?)) - (if (not (buffer-finished? (conn-state-inbound s))) - (pub (tcp-channel src dst ?)) - (gestalt-empty))) + (sub (tcp-channel dst src ?)) + (if (and (conn-state-syn-acked? s) + (not (buffer-finished? (conn-state-inbound s)))) + (pub (tcp-channel src dst ?)) (gestalt-empty)))) (gestalt-union (sub (timer-expired (timer-name ?) ?)) worldward-facing-gestalt @@ -547,7 +546,8 @@ (define is-fin? (set-member? flags 'fin)) (if (and (not expected) ;; no syn yet (or (not is-syn?) ;; and this isn't it - (not (conn-state-listener-listening? s)))) ;; or it is, but no-one local cares + (and (not (conn-state-listener-listening? s)) ;; or it is, but no listener... + (not (conn-state-local-peer-seen? s))))) ;; ...and no outbound client (reset ackn ;; this is *our* seqn (seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0))) ;; ^^ this is what we should acknowledge... From 887c6d99900c831c0a1f2546c8aedb6dcd730049 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 06:52:33 -0400 Subject: [PATCH 38/70] Logging for debugging --- tcp.rkt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tcp.rkt b/tcp.rkt index ee42b55..28d59cf 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -335,6 +335,7 @@ ;; Bitstring ConnState -> Transition (define (incorporate-segment data s) + (log-info "GOT INBOUND STUFF TO DELIVER ~v" data) (transition (if (buffer-finished? (conn-state-inbound s)) s @@ -567,6 +568,7 @@ bump-activity-time quit-when-done))] [(message (tcp-channel _ _ bs) _ _) + (log-info "GOT MORE STUFF TO DELIVER ~v" bs) (sequence-transitions (transition (struct-copy conn-state s [outbound (buffer-push (conn-state-outbound s) bs)]) '()) From 2be8b26ff0555bdf5ff3135e32fc4f2213ee295e Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 06:52:56 -0400 Subject: [PATCH 39/70] Test driver for outbound connections --- fetchurl.rkt | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) create mode 100644 fetchurl.rkt diff --git a/fetchurl.rkt b/fetchurl.rkt new file mode 100644 index 0000000..934d631 --- /dev/null +++ b/fetchurl.rkt @@ -0,0 +1,59 @@ +#lang minimart + +(require minimart/demand-matcher) +(require minimart/drivers/timer) +(require (only-in mzlib/os gethostname)) +(require "configuration.rkt") +(require "ethernet.rkt") +(require "arp.rkt") +(require "ip.rkt") +(require "tcp.rkt") +(require "udp.rkt") + +;;(log-events-and-actions? #t) + +(spawn-timer-driver) +(spawn-ethernet-driver) +(spawn-arp-driver) +(spawn-ip-driver) +(spawn-tcp-driver) +(spawn-udp-driver) + +(spawn (lambda (e s) #f) + (void) + (match (gethostname) + ["skip" + (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) + (pub (host-route (bytes 192 168 1 222) 24 "en0")))] + ["hop" + (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) + (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] + ["stockholm.ccs.neu.edu" + (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) + (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) + (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] + [else + (error 'stack-configuration "No setup for hostname ~a" (gethostname))])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(let () + (define local-handle (tcp-handle 'httpclient)) + (define remote-handle (tcp-address "129.10.115.92" 80)) + + (spawn (lambda (e s) + (log-info "CLIENT: ~v" e) + (match e + [(routing-update g) + #:when (not (gestalt-empty? g)) + (transition s (send (tcp-channel + local-handle + remote-handle + #"GET / HTTP/1.0\r\nHost: stockholm.ccs.neu.edu\r\n\r\n")))] + [(message m _ _) + #f] + [_ #f])) + (void) + (gestalt-union (pub (tcp-channel local-handle remote-handle ?)) + (sub (tcp-channel remote-handle local-handle ?)) + (sub (tcp-channel remote-handle local-handle ?) #:level 1)))) From cee6f9158b4e8eda664cc8d13eb694954e2d60db Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 11:08:56 -0400 Subject: [PATCH 40/70] Adjust debug logging. --- tcp.rkt | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index 28d59cf..93bb853 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -118,13 +118,10 @@ (define local-peer-absent? (gestalt-empty? (gestalt-filter g local-peer-traffic))) (define remote-peer-absent? (gestalt-empty? (gestalt-filter g remote-peer-traffic))) (define new-state (+ (if local-peer-absent? 0 1) (if remote-peer-absent? 0 1))) - (log-info "RELAY OLD ~v NEW ~v" state new-state) (transition new-state (when (< new-state state) (quit)))] [(message (tcp-channel (== local-user-addr) (== remote-addr) bs) _ _) - (log-info "RELAYING ~v" (tcp-channel local-tcp-addr remote-addr bs)) (transition state (send (tcp-channel local-tcp-addr remote-addr bs)))] [(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs) _ _) - (log-info "BACKRELAYING ~v" (tcp-channel remote-addr local-user-addr bs)) (transition state (send (tcp-channel remote-addr local-user-addr bs)))] [_ #f])) 0 @@ -335,7 +332,7 @@ ;; Bitstring ConnState -> Transition (define (incorporate-segment data s) - (log-info "GOT INBOUND STUFF TO DELIVER ~v" data) + ;; (log-info "GOT INBOUND STUFF TO DELIVER ~v" data) (transition (if (buffer-finished? (conn-state-inbound s)) s @@ -397,6 +394,7 @@ [inbound (struct-copy buffer b [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte [finished? #t])]))) + (log-info "Closing inbound stream.") (transition new-s (routing-update (compute-gestalt new-s)))) (transition s '()))) @@ -568,7 +566,7 @@ bump-activity-time quit-when-done))] [(message (tcp-channel _ _ bs) _ _) - (log-info "GOT MORE STUFF TO DELIVER ~v" bs) + ;; (log-info "GOT MORE STUFF TO DELIVER ~v" bs) (sequence-transitions (transition (struct-copy conn-state s [outbound (buffer-push (conn-state-outbound s) bs)]) '()) From c4b14b33312c64de820da24bd6b351eb82d6d759 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 11:54:42 -0400 Subject: [PATCH 41/70] Better printing and exiting --- fetchurl.rkt | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/fetchurl.rkt b/fetchurl.rkt index 934d631..8ce2478 100644 --- a/fetchurl.rkt +++ b/fetchurl.rkt @@ -41,19 +41,23 @@ (define local-handle (tcp-handle 'httpclient)) (define remote-handle (tcp-address "129.10.115.92" 80)) - (spawn (lambda (e s) - (log-info "CLIENT: ~v" e) + (spawn (lambda (e seen-peer?) (match e [(routing-update g) - #:when (not (gestalt-empty? g)) - (transition s (send (tcp-channel - local-handle - remote-handle - #"GET / HTTP/1.0\r\nHost: stockholm.ccs.neu.edu\r\n\r\n")))] - [(message m _ _) + (define peer-present? (not (gestalt-empty? g))) + (transition (or seen-peer? peer-present?) + (if (and (not peer-present?) seen-peer?) + (quit) + (send (tcp-channel + local-handle + remote-handle + #"GET / HTTP/1.0\r\nHost: stockholm.ccs.neu.edu\r\n\r\n"))))] + [(message (tcp-channel _ _ bs) _ _) + (printf "----------------------------------------\n~a\n" bs) + (printf "----------------------------------------\n") #f] [_ #f])) - (void) + #f (gestalt-union (pub (tcp-channel local-handle remote-handle ?)) (sub (tcp-channel remote-handle local-handle ?)) (sub (tcp-channel remote-handle local-handle ?) #:level 1)))) From 7456e2efec9854781e82990881d825d761ff1767 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 11:55:05 -0400 Subject: [PATCH 42/70] Time out TCP relay process if peers don't show up --- tcp.rkt | 46 +++++++++++++++++++++++++++------------------- 1 file changed, 27 insertions(+), 19 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index 93bb853..2c08374 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -109,28 +109,36 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Relay between kernel-level and user-level +(define relay-peer-wait-time-msec 5000) + (define ((spawn-relay local-user-addr) remote-addr local-tcp-addr) + (define timer-name (list 'spawn-relay local-tcp-addr remote-addr)) (define local-peer-traffic (pub (tcp-channel remote-addr local-user-addr ?) #:level 1)) (define remote-peer-traffic (sub (tcp-channel remote-addr local-tcp-addr ?) #:level 1)) - (spawn (lambda (e state) - (match e - [(routing-update g) - (define local-peer-absent? (gestalt-empty? (gestalt-filter g local-peer-traffic))) - (define remote-peer-absent? (gestalt-empty? (gestalt-filter g remote-peer-traffic))) - (define new-state (+ (if local-peer-absent? 0 1) (if remote-peer-absent? 0 1))) - (transition new-state (when (< new-state state) (quit)))] - [(message (tcp-channel (== local-user-addr) (== remote-addr) bs) _ _) - (transition state (send (tcp-channel local-tcp-addr remote-addr bs)))] - [(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs) _ _) - (transition state (send (tcp-channel remote-addr local-user-addr bs)))] - [_ #f])) - 0 - (gestalt-union local-peer-traffic - remote-peer-traffic - (sub (tcp-channel remote-addr local-tcp-addr ?)) - (sub (tcp-channel local-user-addr remote-addr ?)) - (pub (tcp-channel remote-addr local-user-addr ?)) - (pub (tcp-channel local-tcp-addr remote-addr ?))))) + (list + (send (set-timer timer-name relay-peer-wait-time-msec 'relative)) + (spawn (lambda (e state) + (match e + [(routing-update g) + (define local-peer-absent? (gestalt-empty? (gestalt-filter g local-peer-traffic))) + (define remote-peer-absent? (gestalt-empty? (gestalt-filter g remote-peer-traffic))) + (define new-state (+ (if local-peer-absent? 0 1) (if remote-peer-absent? 0 1))) + (transition new-state (when (< new-state state) (quit)))] + [(message (tcp-channel (== local-user-addr) (== remote-addr) bs) _ _) + (transition state (send (tcp-channel local-tcp-addr remote-addr bs)))] + [(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs) _ _) + (transition state (send (tcp-channel remote-addr local-user-addr bs)))] + [(message (timer-expired _ _) _ _) + (error 'spawn-relay "TCP relay process timed out waiting for peer")] + [_ #f])) + 0 + (gestalt-union local-peer-traffic + remote-peer-traffic + (sub (tcp-channel remote-addr local-tcp-addr ?)) + (sub (tcp-channel local-user-addr remote-addr ?)) + (pub (tcp-channel remote-addr local-user-addr ?)) + (pub (tcp-channel local-tcp-addr remote-addr ?)) + (sub (timer-expired timer-name ?)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Codec & kernel-level driver From 50fc02f899e3a7e5b651e4c4dbd87ac663834ac1 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 12:01:50 -0400 Subject: [PATCH 43/70] "Web server" --- main.rkt | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/main.rkt b/main.rkt index 3013dd2..8e1e81f 100644 --- a/main.rkt +++ b/main.rkt @@ -94,6 +94,28 @@ (void) (gestalt-union (sub (udp-packet ? (udp-listener 6667) ?))))) +(let () + (define (spawn-session them us) + (list + (send #:meta-level 1 + (tcp-channel us them + #"HTTP/1.0 200 OK\r\n\r\n

Hello world from minimart-netstack!

")) + (spawn (lambda (e s) + (match e + [(routing-update g) (transition s (quit))] + [_ #f])) + (void) + (gestalt-union (sub (tcp-channel them us ?) #:meta-level 1) + (sub (tcp-channel them us ?) #:meta-level 1 #:level 1) + (pub (tcp-channel us them ?) #:meta-level 1))))) + + (spawn-world + (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?) + #:meta-level 1 + spawn-session)) + + ) + (spawn (lambda (e s) (local-require racket/pretty) (match e From b98e0bedb8cd7c532704f15f143d2df7fedbc3d8 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 12:08:40 -0400 Subject: [PATCH 44/70] Better page :-) --- main.rkt | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/main.rkt b/main.rkt index 8e1e81f..846e082 100644 --- a/main.rkt +++ b/main.rkt @@ -99,7 +99,12 @@ (list (send #:meta-level 1 (tcp-channel us them - #"HTTP/1.0 200 OK\r\n\r\n

Hello world from minimart-netstack!

")) + (bytes-append + #"HTTP/1.0 200 OK\r\n\r\n" + #"

Hello world from minimart-netstack!

\n" + #"

This is running on minimart's own\n" + #"\n" + #"TCP/IP stack.

"))) (spawn (lambda (e s) (match e [(routing-update g) (transition s (quit))] From 4451795146a4e61701f7f51546aca011a0c88fa9 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 12:18:21 -0400 Subject: [PATCH 45/70] Hit counter. --- main.rkt | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/main.rkt b/main.rkt index 846e082..84b86df 100644 --- a/main.rkt +++ b/main.rkt @@ -97,24 +97,38 @@ (let () (define (spawn-session them us) (list - (send #:meta-level 1 - (tcp-channel us them - (bytes-append - #"HTTP/1.0 200 OK\r\n\r\n" - #"

Hello world from minimart-netstack!

\n" - #"

This is running on minimart's own\n" - #"\n" - #"TCP/IP stack.

"))) + (send 'bump) (spawn (lambda (e s) (match e - [(routing-update g) (transition s (quit))] + [(message `(counter ,counter) _ _) + (define response + (string->bytes/utf-8 + (format (string-append + "HTTP/1.0 200 OK\r\n\r\n" + "

Hello world from minimart-netstack!

\n" + "

This is running on minimart's own\n" + "\n" + "TCP/IP stack.

\n" + "

There have been ~a requests prior to this one.

") + counter))) + (transition s (list (send #:meta-level 1 (tcp-channel us them response)) + (quit)))] [_ #f])) (void) - (gestalt-union (sub (tcp-channel them us ?) #:meta-level 1) + (gestalt-union (sub `(counter ,?)) + (sub (tcp-channel them us ?) #:meta-level 1) (sub (tcp-channel them us ?) #:meta-level 1 #:level 1) (pub (tcp-channel us them ?) #:meta-level 1))))) (spawn-world + (spawn (lambda (e counter) + (match e + [(message 'bump _ _) + (transition (+ counter 1) (send `(counter ,counter)))] + [_ #f])) + 0 + (gestalt-union (sub 'bump) + (pub `(counter ,?)))) (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?) #:meta-level 1 spawn-session)) From 0a5abb8fff0b1bbbd8e7c97bb89a36f09d72ddbd Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 21 Jun 2014 12:23:23 -0400 Subject: [PATCH 46/70] Handle incoming RST --- tcp.rkt | 48 ++++++++++++++++++++++++++---------------------- 1 file changed, 26 insertions(+), 22 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index 2c08374..b763c45 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -551,28 +551,32 @@ (define expected (next-expected-seqn s)) (define is-syn? (set-member? flags 'syn)) (define is-fin? (set-member? flags 'fin)) - (if (and (not expected) ;; no syn yet - (or (not is-syn?) ;; and this isn't it - (and (not (conn-state-listener-listening? s)) ;; or it is, but no listener... - (not (conn-state-local-peer-seen? s))))) ;; ...and no outbound client - (reset ackn ;; this is *our* seqn - (seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0))) - ;; ^^ this is what we should acknowledge... - s) - (sequence-transitions (cond - [(not expected) ;; haven't seen syn yet, but we know this is it - (incorporate-segment data (set-inbound-seqn (seq+ seqn 1) s))] - [(= expected seqn) - (incorporate-segment data s)] - [else - (transition s '())]) - deliver-inbound-locally - (check-fin flags) - (discard-acknowledged-outbound (set-member? flags 'ack) ackn) - (update-outbound-window window) - (send-outbound old-ackn) - bump-activity-time - quit-when-done))] + (cond + [(set-member? flags 'rst) + (transition s (quit))] + [(and (not expected) ;; no syn yet + (or (not is-syn?) ;; and this isn't it + (and (not (conn-state-listener-listening? s)) ;; or it is, but no listener... + (not (conn-state-local-peer-seen? s))))) ;; ...and no outbound client + (reset ackn ;; this is *our* seqn + (seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0))) + ;; ^^ this is what we should acknowledge... + s)] + [else + (sequence-transitions (cond + [(not expected) ;; haven't seen syn yet, but we know this is it + (incorporate-segment data (set-inbound-seqn (seq+ seqn 1) s))] + [(= expected seqn) + (incorporate-segment data s)] + [else + (transition s '())]) + deliver-inbound-locally + (check-fin flags) + (discard-acknowledged-outbound (set-member? flags 'ack) ackn) + (update-outbound-window window) + (send-outbound old-ackn) + bump-activity-time + quit-when-done)])] [(message (tcp-channel _ _ bs) _ _) ;; (log-info "GOT MORE STUFF TO DELIVER ~v" bs) (sequence-transitions (transition (struct-copy conn-state s From 974c8a5807ed76b1d744134357b09170f8d0d417 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 30 Jun 2014 08:20:09 -0400 Subject: [PATCH 47/70] Avoid gratuitous timeout --- tcp.rkt | 1 + 1 file changed, 1 insertion(+) diff --git a/tcp.rkt b/tcp.rkt index b763c45..2f5df59 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -129,6 +129,7 @@ [(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs) _ _) (transition state (send (tcp-channel remote-addr local-user-addr bs)))] [(message (timer-expired _ _) _ _) + #:when (< state 2) ;; we only care if we're not fully connected (error 'spawn-relay "TCP relay process timed out waiting for peer")] [_ #f])) 0 From 32d8922b28d81c097b96d45d5d3cce07b66fb624 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Mon, 30 Jun 2014 08:20:17 -0400 Subject: [PATCH 48/70] walk is like hop --- main.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main.rkt b/main.rkt index 84b86df..685ce32 100644 --- a/main.rkt +++ b/main.rkt @@ -25,7 +25,7 @@ ["skip" (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) (pub (host-route (bytes 192 168 1 222) 24 "en0")))] - ["hop" + [(or "hop" "walk") (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] ["stockholm.ccs.neu.edu" From 4c6dd497c12fb563c5a6412c723ff3f530c2a30d Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 9 Jul 2015 10:43:55 -0400 Subject: [PATCH 49/70] TODO --- TODO.md | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 TODO.md diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000..d775f4a --- /dev/null +++ b/TODO.md @@ -0,0 +1,12 @@ +Ideas on TCP unit testing: + + +Check behaviour around TCP zero-window probing. Is the correct +behaviour already a consequence of the way `send-outbound` works? + +Do something smarter with TCP timers and RTT estimation than the +nothing that's already being done. + +TCP options negotiation. + - SACK + - Window scaling From 63039b63f0d43250c0ff1e45119172b9ca61a9b0 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 9 Jul 2015 14:03:46 -0400 Subject: [PATCH 50/70] A bug --- TODO.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/TODO.md b/TODO.md index d775f4a..8d674d5 100644 --- a/TODO.md +++ b/TODO.md @@ -10,3 +10,9 @@ nothing that's already being done. TCP options negotiation. - SACK - Window scaling + +Bugs: + - RST kills a connection even if its sequence number is bogus. Check + to make sure it's in the window. (See + http://static.googleusercontent.com/media/research.google.com/en//pubs/archive/41848.pdf + and RFC 5961) From 0072607f65c95c3d037a5d5d6d10e18f5c4786b3 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 17 Oct 2015 20:33:10 -0400 Subject: [PATCH 51/70] Factor out demo stack configuration --- demo-config.rkt | 26 ++++++++++++++++++++++++++ fetchurl.rkt | 20 ++------------------ main.rkt | 20 ++------------------ 3 files changed, 30 insertions(+), 36 deletions(-) create mode 100644 demo-config.rkt diff --git a/demo-config.rkt b/demo-config.rkt new file mode 100644 index 0000000..4b065d2 --- /dev/null +++ b/demo-config.rkt @@ -0,0 +1,26 @@ +#lang racket/base +;; Demonstration stack configuration for various hosts. + +(require racket/match) +(require minimart) +(require (only-in mzlib/os gethostname)) +(require "configuration.rkt") + +(provide spawn-demo-config) + +(define (spawn-demo-config) + (spawn (lambda (e s) #f) + (void) + (match (gethostname) + ["skip" + (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) + (pub (host-route (bytes 192 168 1 222) 24 "en0")))] + [(or "hop" "walk") + (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) + (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] + ["stockholm.ccs.neu.edu" + (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) + (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) + (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] + [else + (error 'spawn-demo-config "No setup for hostname ~a" (gethostname))]))) diff --git a/fetchurl.rkt b/fetchurl.rkt index 8ce2478..105bfa0 100644 --- a/fetchurl.rkt +++ b/fetchurl.rkt @@ -2,8 +2,7 @@ (require minimart/demand-matcher) (require minimart/drivers/timer) -(require (only-in mzlib/os gethostname)) -(require "configuration.rkt") +(require "demo-config.rkt") (require "ethernet.rkt") (require "arp.rkt") (require "ip.rkt") @@ -18,22 +17,7 @@ (spawn-ip-driver) (spawn-tcp-driver) (spawn-udp-driver) - -(spawn (lambda (e s) #f) - (void) - (match (gethostname) - ["skip" - (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) - (pub (host-route (bytes 192 168 1 222) 24 "en0")))] - ["hop" - (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) - (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] - ["stockholm.ccs.neu.edu" - (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) - (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) - (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] - [else - (error 'stack-configuration "No setup for hostname ~a" (gethostname))])) +(spawn-demo-config) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/main.rkt b/main.rkt index 685ce32..af9d6af 100644 --- a/main.rkt +++ b/main.rkt @@ -2,8 +2,7 @@ (require minimart/demand-matcher) (require minimart/drivers/timer) -(require (only-in mzlib/os gethostname)) -(require "configuration.rkt") +(require "demo-config.rkt") (require "ethernet.rkt") (require "arp.rkt") (require "ip.rkt") @@ -18,22 +17,7 @@ (spawn-ip-driver) (spawn-tcp-driver) (spawn-udp-driver) - -(spawn (lambda (e s) #f) - (void) - (match (gethostname) - ["skip" - (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) - (pub (host-route (bytes 192 168 1 222) 24 "en0")))] - [(or "hop" "walk") - (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) - (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] - ["stockholm.ccs.neu.edu" - (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) - (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) - (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] - [else - (error 'stack-configuration "No setup for hostname ~a" (gethostname))])) +(spawn-demo-config) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From e6530e2e4a055f6c0ff5d33f10a315121afc00b6 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 17 Oct 2015 20:33:51 -0400 Subject: [PATCH 52/70] Entrypoint for simply idling the stack --- idle.rkt | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 idle.rkt diff --git a/idle.rkt b/idle.rkt new file mode 100644 index 0000000..f356329 --- /dev/null +++ b/idle.rkt @@ -0,0 +1,20 @@ +#lang minimart + +(require minimart/demand-matcher) +(require minimart/drivers/timer) +(require "demo-config.rkt") +(require "ethernet.rkt") +(require "arp.rkt") +(require "ip.rkt") +(require "tcp.rkt") +(require "udp.rkt") + +;;(log-events-and-actions? #t) + +(spawn-timer-driver) +(spawn-ethernet-driver) +(spawn-arp-driver) +(spawn-ip-driver) +(spawn-tcp-driver) +(spawn-udp-driver) +(spawn-demo-config) From 543073fd2ed0d2e509a406d9042205e4edc6a97a Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 17 Oct 2015 21:11:55 -0400 Subject: [PATCH 53/70] README --- README.md | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 README.md diff --git a/README.md b/README.md new file mode 100644 index 0000000..bbf36a5 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +# TCP/IP Stack + +## Linux Firewall Configuration + +Imagine a setup where the machine you are running this code has IP +192.168.1.10. This code claims 192.168.1.222 for itself. Now, pinging +192.168.1.222 from some other machine, say 192.168.1.99, will cause +the local kernel to receive the pings and then *forward them on to +192.168.1.222*, which because of the gratuitous ARP announcement, it +knows to be on its own Ethernet MAC address. This causes the ping +requests to repeat endlessly, each time with one lower TTL. + +One approach to solving the problem is to prevent the kernel from +forwarding packets addressed to 192.168.1.222. To do this, + + sudo iptables -I FORWARD -d 192.168.1.222 -j DROP From ca5bf47adf30e4e5e8809d1f18fecbd6e684a287 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 23 Jan 2016 20:11:59 -0500 Subject: [PATCH 54/70] Initial work towards migration from minimart to prospect-monolithic --- arp.rkt | 148 ++++++++++++++++---------------- configuration.rkt | 6 +- demo-config.rkt | 16 ++-- ethernet.rkt | 65 ++++++-------- fetchurl.rkt | 6 +- ip.rkt | 210 +++++++++++++++++++++------------------------ main.rkt | 141 +++++++++++++----------------- port-allocator.rkt | 2 +- tcp.rkt | 6 +- udp.rkt | 4 +- 10 files changed, 279 insertions(+), 325 deletions(-) diff --git a/arp.rkt b/arp.rkt index 657b8b9..fb647b5 100644 --- a/arp.rkt +++ b/arp.rkt @@ -9,9 +9,9 @@ (require racket/set) (require racket/match) -(require minimart) -(require minimart/drivers/timer) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/drivers/timer) +(require prospect-monolithic/demand-matcher) (require bitsyntax) (require "dump-bytes.rkt") @@ -22,6 +22,8 @@ (struct arp-assertion (protocol protocol-address interface-name) #:prefab) (struct arp-interface (interface-name) #:prefab) +(struct arp-interface-up (interface-name) #:prefab) + (define ARP-ethertype #x0806) (define cache-entry-lifetime-msec (* 14400 1000)) (define wakeup-interval 5000) @@ -30,7 +32,7 @@ (define (spawn-arp-driver) (spawn-demand-matcher (arp-interface (?!)) - #:supply-level 1 + (arp-interface-up (?!)) spawn-arp-interface)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -42,13 +44,10 @@ (define (spawn-arp-interface interface-name) (log-info "spawn-arp-interface ~v" interface-name) - (lookup-ethernet-hwaddr (gestalt-for-supply interface-name) + (lookup-ethernet-hwaddr (assertion (arp-interface-up interface-name)) interface-name (lambda (hwaddr) (spawn-arp-interface* interface-name hwaddr)))) -(define (gestalt-for-supply interface-name) - (sub (arp-interface interface-name) #:level 1)) - (define (spawn-arp-interface* interface-name hwaddr) (log-info "spawn-arp-interface* ~v ~v" interface-name hwaddr) (define interface (ethernet-interface interface-name hwaddr)) @@ -62,21 +61,20 @@ (define timer-key (list 'arp interface-name)) (define (set-wakeup-alarm) - (send (set-timer timer-key wakeup-interval 'relative))) + (message (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)) - (gestalt-for-supply interface-name) - (sub (arp-assertion ? ? interface-name) #:level 1) - (pub (arp-query ? ? interface ?) #: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-interface v) - (cache-value-address v))))))) + (scn/union (subscription (timer-expired timer-key ?)) + (subscription interface) + (subscription (ethernet-packet-pattern interface-name #t ARP-ethertype)) + (assertion (arp-interface-up interface-name)) + (subscription (arp-assertion ? ? interface-name)) + (subscription (observe (arp-query ? ? interface ?))) + (for/fold [(g (trie-empty))] [((k v) (in-hash cache))] + (assertion-set-union g (assertion (arp-query (cache-key-protocol k) + (cache-key-address k) + (cache-value-interface v) + (cache-value-address v))))))) (define (build-packet dest-mac ptype oper sender-ha sender-pa target-ha target-pa) (define hlen (bytes-length target-ha)) @@ -135,40 +133,39 @@ cache-entry-lifetime-msec) interface 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)) - (begin - (log-info "~a ARP answering request for ~a/~a" - interface-name - ptype - (pretty-bytes target-protocol-address)) - (send (build-packet sender-hardware-address - ptype - 2 ;; reply - hwaddr - target-protocol-address - sender-hardware-address - sender-protocol-address))) - '())] - [(2) '()] ;; reply - [else '()]) - (routing-update (compute-gestalt cache)))))) + (transition (struct-copy state s [cache cache]) + (list + (case oper + [(1) ;; request + (if (set-member? (state-assertions s) + (cache-key ptype target-protocol-address)) + (begin + (log-info "~a ARP answering request for ~a/~a" + interface-name + ptype + (pretty-bytes target-protocol-address)) + (message (build-packet sender-hardware-address + ptype + 2 ;; reply + hwaddr + target-protocol-address + sender-hardware-address + sender-protocol-address))) + '())] + [(2) '()] ;; reply + [else '()]) + (compute-gestalt cache))))) (else #f))) - (define queries-projection (project-subs #:level 1 (arp-query (?!) (?!) ? ?))) + (define queries-projection (compile-projection (observe (arp-query (?!) (?!) ? ?)))) (define (gestalt->queries g) - (for/set [(e (in-set (gestalt-project/keys g queries-projection)))] + (for/set [(e (in-set (trie-project/set g queries-projection)))] (match-define (list ptype pa) e) (cache-key ptype pa))) - (define assertions-projection (project-pubs (arp-assertion (?!) (?!) ?))) + (define assertions-projection (compile-projection (arp-assertion (?!) (?!) ?))) (define (gestalt->assertions g) - (for/set [(e (in-set (gestalt-project/keys g assertions-projection)))] + (for/set [(e (in-set (trie-project/set g assertions-projection)))] (match-define (list ptype pa) e) (cache-key ptype pa))) @@ -176,22 +173,22 @@ (define new-assertions (gestalt->assertions g)) (define added-assertions (set-subtract new-assertions (state-assertions s))) (define new-s (struct-copy state s [queries (gestalt->queries g)] [assertions new-assertions])) - (transition new-s - (list - (when (gestalt-empty? (gestalt-filter g (gestalt-for-supply interface-name))) - (quit)) - (for/list [(a (in-set added-assertions))] - (log-info "~a ARP Announcing ~a as ~a" - interface-name - (pretty-bytes (cache-key-address a)) - (pretty-bytes hwaddr)) - (send (build-packet broadcast-ethernet-address - (cache-key-protocol a) - 2 ;; reply -- gratuitous announcement - hwaddr - (cache-key-address a) - hwaddr - (cache-key-address a))))))) + (if (trie-empty? (project-assertions g (arp-interface interface-name))) + (quit) + (transition new-s + (list + (for/list [(a (in-set added-assertions))] + (log-info "~a ARP Announcing ~a as ~a" + interface-name + (pretty-bytes (cache-key-address a)) + (pretty-bytes hwaddr)) + (message (build-packet broadcast-ethernet-address + (cache-key-protocol a) + 2 ;; reply -- gratuitous announcement + hwaddr + (cache-key-address a) + hwaddr + (cache-key-address a)))))))) (define (send-questions s) (define unanswered-queries @@ -209,30 +206,29 @@ (pretty-bytes (cache-key-address q)) (and pa (pretty-bytes pa))) (when pa - (send (build-packet broadcast-ethernet-address - (cache-key-protocol q) - 1 ;; request - hwaddr - pa - zero-ethernet-address - (cache-key-address q))))))) + (message (build-packet broadcast-ethernet-address + (cache-key-protocol q) + 1 ;; request + hwaddr + pa + zero-ethernet-address + (cache-key-address q))))))) (list (set-wakeup-alarm) (spawn (lambda (e s) ;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s) (match e - [(routing-update g) + [(scn g) (sequence-transitions (analyze-gestalt g s) send-questions)] - [(message (ethernet-packet _ _ source destination _ body) _ _) + [(message (ethernet-packet _ _ source destination _ body)) (analyze-incoming-packet source destination body s)] - [(message (timer-expired _ _) _ _) + [(message (timer-expired _ _)) (define new-s (struct-copy state s [cache (expire-cache (state-cache s))])) - (define new-g (compute-gestalt (state-cache new-s))) (sequence-transitions (transition new-s (list (set-wakeup-alarm) - (routing-update new-g))) + (compute-gestalt (state-cache new-s)))) send-questions)] [_ #f])) (state (hash) (set) (set)) diff --git a/configuration.rkt b/configuration.rkt index 665320c..01c8a86 100644 --- a/configuration.rkt +++ b/configuration.rkt @@ -3,7 +3,9 @@ (provide (struct-out ethernet-interface) (struct-out host-route) (struct-out gateway-route) - (struct-out net-route)) + (struct-out net-route) + + (struct-out route-up)) (struct ethernet-interface (name hwaddr) #:prefab) @@ -15,3 +17,5 @@ (struct host-route (ip-addr netmask interface-name) #:prefab) (struct gateway-route (network-addr netmask gateway-addr interface-name) #:prefab) (struct net-route (network-addr netmask link) #:prefab) + +(struct route-up (route) #:prefab) ;; assertion: the given Route is running diff --git a/demo-config.rkt b/demo-config.rkt index 4b065d2..1740e58 100644 --- a/demo-config.rkt +++ b/demo-config.rkt @@ -2,7 +2,7 @@ ;; Demonstration stack configuration for various hosts. (require racket/match) -(require minimart) +(require prospect-monolithic) (require (only-in mzlib/os gethostname)) (require "configuration.rkt") @@ -13,14 +13,14 @@ (void) (match (gethostname) ["skip" - (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) - (pub (host-route (bytes 192 168 1 222) 24 "en0")))] + (scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0")) + (assertion (host-route (bytes 192 168 1 222) 24 "en0")))] [(or "hop" "walk") - (gestalt-union (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) - (pub (host-route (bytes 192 168 1 222) 24 "wlan0")))] + (scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0")) + (assertion (host-route (bytes 192 168 1 222) 24 "wlan0")))] ["stockholm.ccs.neu.edu" - (gestalt-union (pub (host-route (bytes 129 10 115 94) 24 "eth0")) - (pub (host-route (bytes 192 168 56 222) 24 "vboxnet0")) - (pub (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] + (scn/union (assertion (host-route (bytes 129 10 115 94) 24 "eth0")) + (assertion (host-route (bytes 192 168 56 222) 24 "vboxnet0")) + (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] [else (error 'spawn-demo-config "No setup for hostname ~a" (gethostname))]))) diff --git a/ethernet.rkt b/ethernet.rkt index 8ae6da1..d985eb4 100644 --- a/ethernet.rkt +++ b/ethernet.rkt @@ -6,8 +6,6 @@ broadcast-ethernet-address interface-names spawn-ethernet-driver - ethernet-hwaddr-projection - gestalt->hwaddr ethernet-packet-pattern lookup-ethernet-hwaddr) @@ -15,8 +13,8 @@ (require racket/match) (require racket/async-channel) -(require minimart) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/demand-matcher) (require packet-socket) (require bitsyntax) @@ -33,8 +31,8 @@ (log-info "Device names: ~a" interface-names) (define (spawn-ethernet-driver) - (spawn-demand-matcher (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?) - #:demand-is-subscription? #t + (spawn-demand-matcher (observe (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?)) + (ethernet-interface (?!) ?) spawn-interface-tap)) (define (spawn-interface-tap interface-name) @@ -50,22 +48,21 @@ (thread (lambda () (interface-packet-read-loop interface h control-ch))) (spawn (lambda (e h) (match e - [(routing-update g) - - (if (gestalt-empty? g) + [(scn g) + (if (trie-empty? g) (begin (async-channel-put control-ch 'quit) - (transition #f (quit))) + (quit)) (begin (async-channel-put control-ch 'unblock) #f))] - [(message (? ethernet-packet? p) 1 #f) ;; from metalevel 1 + [(message (at-meta (? ethernet-packet? p))) ;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~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)) ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) - (transition h (send p))] - [(message (? ethernet-packet? p) 0 #f) ;; from metalevel 0 + (transition h (message p))] + [(message (? ethernet-packet? p)) ;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)" ;; (ethernet-interface-name (ethernet-packet-interface p)) ;; (pretty-bytes (ethernet-packet-source p)) @@ -76,10 +73,10 @@ #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)))])) + (scn/union (assertion interface) + (subscription (ethernet-packet interface #f ? ? ? ?)) + (subscription (observe (ethernet-packet interface #t ? ? ? ?))) + (subscription (ethernet-packet interface #t ? ? ? ?) #:meta-level 1)))])) (define (interface-packet-read-loop interface h control-ch) (define (blocked) @@ -120,29 +117,17 @@ (ethertype :: integer bytes 2) (body :: binary)))) -(define (ethernet-hwaddr-projection interface-name) - (project-pubs (ethernet-packet (ethernet-interface interface-name (?!)) #t ? ? ? ?))) - -(define (gestalt->hwaddr g interface-name) - (define hwaddrs (gestalt-project/single g (ethernet-hwaddr-projection interface-name))) - (case (set-count hwaddrs) - [(0) #f] - [(1) (set-first hwaddrs)] - [else - (log-warning "gestalt->hwaddr: multiple addresses for interface ~a: ~v" interface-name hwaddrs) - (set-first hwaddrs)])) - (define (ethernet-packet-pattern interface-name from-wire? ethertype) (ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?)) -(define (lookup-ethernet-hwaddr base-gestalt interface-name k) - (on-gestalt #:timeout-msec 5000 - #:on-timeout (lambda () - (log-info "Lookup of ethernet interface ~v failed" interface-name) - '()) - (lambda (_g hwaddrss) - (and (not (set-empty? hwaddrss)) - (let ((hwaddr (car (set-first hwaddrss)))) - (k hwaddr)))) - base-gestalt - (ethernet-hwaddr-projection interface-name))) +(define (lookup-ethernet-hwaddr base-interests interface-name k) + (on-claim #:timeout-msec 5000 + #:on-timeout (lambda () + (log-info "Lookup of ethernet interface ~v failed" interface-name) + '()) + (lambda (_g hwaddrss) + (and (not (set-empty? hwaddrss)) + (let ((hwaddr (car (set-first hwaddrss)))) + (k hwaddr)))) + base-interests + (ethernet-interface interface-name (?!)))) diff --git a/fetchurl.rkt b/fetchurl.rkt index 105bfa0..24469b6 100644 --- a/fetchurl.rkt +++ b/fetchurl.rkt @@ -1,7 +1,7 @@ -#lang minimart +#lang prospect-monolithic -(require minimart/demand-matcher) -(require minimart/drivers/timer) +(require prospect-monolithic/demand-matcher) +(require prospect-monolithic/drivers/timer) (require "demo-config.rkt") (require "ethernet.rkt") (require "arp.rkt") diff --git a/ip.rkt b/ip.rkt index 8106801..3e98837 100644 --- a/ip.rkt +++ b/ip.rkt @@ -13,9 +13,9 @@ (require racket/set) (require racket/match) (require (only-in racket/string string-split)) -(require minimart) -(require minimart/drivers/timer) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/drivers/timer) +(require prospect-monolithic/demand-matcher) (require bitsyntax) (require "dump-bytes.rkt") @@ -53,48 +53,38 @@ (define broadcast-ip-address (bytes 255 255 255 255)) -(define local-ip-address-projector (project-pubs (host-route (?!) ? ?))) -(define (gestalt->local-ip-addresses g) (gestalt-project/single g local-ip-address-projector)) -(define observe-local-ip-addresses-gestalt (sub (host-route ? ? ?) #:level 2)) +(define local-ip-address-projector (compile-projection (host-route (?!) ? ?))) +(define (gestalt->local-ip-addresses g) (trie-project/set/single g local-ip-address-projector)) +(define observe-local-ip-addresses-gestalt (subscription (host-route ? ? ?))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (spawn-ip-driver) (list (spawn-demand-matcher (host-route (?!) (?!) (?!)) - #:supply-level 1 + (route-up (host-route (?!) (?!) (?!))) spawn-host-route) (spawn-demand-matcher (gateway-route (?!) (?!) (?!) (?!)) - #:supply-level 1 + (route-up (gateway-route (?!) (?!) (?!) (?!))) spawn-gateway-route) (spawn-demand-matcher (net-route (?!) (?!) (?!)) - #:supply-level 1 + (route-up (net-route (?!) (?!) (?!))) spawn-net-route))) -(define (host-route-supply ip-addr netmask interface-name) - (sub (host-route ip-addr netmask interface-name) #:level 1)) - -(define (gateway-route-supply network-addr netmask gateway-addr interface-name) - (sub (gateway-route network-addr netmask gateway-addr interface-name) #:level 1)) - -(define (net-route-supply network-addr netmask link) - (sub (net-route network-addr netmask link) #:level 1)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Local IP route (define (spawn-host-route my-address netmask interface-name) (list (let ((network-addr (apply-netmask my-address netmask))) - (spawn-normal-ip-route (host-route-supply my-address netmask interface-name) + (spawn-normal-ip-route (host-route my-address netmask interface-name) network-addr netmask interface-name)) (spawn (lambda (e s) (match e - [(routing-update g) - (transition s (when (gestalt-empty? g) (quit)))] - [(message (ip-packet _ peer-address _ _ _ body) _ _) + [(scn (? trie-empty?)) (quit)] + [(message (ip-packet _ peer-address _ _ _ body)) (bit-string-case body ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum (case type @@ -106,12 +96,12 @@ code (0 :: integer bytes 2) ;; TODO (rest :: binary))) - (transition s (send (ip-packet #f - my-address - peer-address - PROTOCOL-ICMP - #"" - (ip-checksum 2 reply-data0))))] + (transition s (message (ip-packet #f + my-address + peer-address + PROTOCOL-ICMP + #"" + (ip-checksum 2 reply-data0))))] [else (log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a" type @@ -124,10 +114,10 @@ (else #f))] [_ #f])) (void) - (gestalt-union (pub (ip-packet ? my-address ? PROTOCOL-ICMP ? ?)) - (sub (ip-packet ? ? my-address PROTOCOL-ICMP ? ?)) - (pub (arp-assertion IPv4-ethertype my-address interface-name)) - (host-route-supply my-address netmask interface-name))))) + (scn/union (advertisement (ip-packet ? my-address ? PROTOCOL-ICMP ? ?)) + (subscription (ip-packet ? ? my-address PROTOCOL-ICMP ? ?)) + (assertion (arp-assertion IPv4-ethertype my-address interface-name)) + (subscription (host-route my-address netmask interface-name)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Gateway IP route @@ -135,15 +125,16 @@ (struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent) (define (spawn-gateway-route network netmask gateway-addr interface-name) - (define gestalt-for-supply (gateway-route-supply network netmask gateway-addr interface-name)) + (define the-route (gateway-route network netmask gateway-addr interface-name)) - (define host-route-projector (project-subs (host-route (?!) ? ?))) - (define gateway-route-projector (project-subs (gateway-route (?!) (?!) ? ?))) - (define net-route-projector (project-subs (net-route (?!) (?!) ?))) - (define gateway-arp-projector (project-pubs (arp-query IPv4-ethertype - gateway-addr - (?! (ethernet-interface interface-name ?)) - (?!)))) + (define host-route-projector (compile-projection (host-route (?!) ? ?))) + (define gateway-route-projector (compile-projection (gateway-route (?!) (?!) ? ?))) + (define net-route-projector (compile-projection (net-route (?!) (?!) ?))) + (define gateway-arp-projector (compile-projection + (arp-query IPv4-ethertype + gateway-addr + (?! (ethernet-interface interface-name ?)) + (?!)))) (define (covered-by-some-other-route? addr routes) (for/or ([r (in-set routes)]) @@ -153,25 +144,27 @@ (spawn (lambda (e s) (match e - [(routing-update g) - (define host-ips (gestalt-project/single g host-route-projector)) - (define gw-nets+netmasks (gestalt-project/keys g gateway-route-projector)) - (define net-nets+netmasks (gestalt-project/keys g net-route-projector)) - (define gw-ip+hwaddr (let ((vs (gestalt-project/keys g gateway-arp-projector))) + [(scn g) + (define host-ips (trie-project/set/single g host-route-projector)) + (define gw-nets+netmasks (trie-project/set g gateway-route-projector)) + (define net-nets+netmasks (trie-project/set g net-route-projector)) + (define gw-ip+hwaddr (let ((vs (trie-project/set g gateway-arp-projector))) (and vs (not (set-empty? vs)) (set-first vs)))) (when (and gw-ip+hwaddr (not (gateway-route-state-gateway-hwaddr s))) (log-info "Discovered gateway ~a at ~a on interface ~a." (ip-address->hostname gateway-addr) (ethernet-interface-name (car gw-ip+hwaddr)) (pretty-bytes (cadr gw-ip+hwaddr)))) - (transition (gateway-route-state - (set-union (for/set ([ip host-ips]) (list ip 32)) - gw-nets+netmasks - net-nets+netmasks) - (and gw-ip+hwaddr (car gw-ip+hwaddr)) - (and gw-ip+hwaddr (cadr gw-ip+hwaddr))) - (when (gestalt-empty? (gestalt-filter g gestalt-for-supply)) (quit)))] - [(message (? ip-packet? p) _ _) + (if (trie-empty? (project-assertions g (?! the-route))) + (quit) + (transition (gateway-route-state + (set-union (for/set ([ip host-ips]) (list ip 32)) + gw-nets+netmasks + net-nets+netmasks) + (and gw-ip+hwaddr (car gw-ip+hwaddr)) + (and gw-ip+hwaddr (cadr gw-ip+hwaddr))) + '()))] + [(message (? ip-packet? p)) (define gw-if (gateway-route-state-gateway-interface s)) (when (not gw-if) (log-warning "Gateway hwaddr for ~a not known, packet dropped." @@ -181,42 +174,39 @@ (not (covered-by-some-other-route? (ip-packet-destination p) (gateway-route-state-routes s))) (transition s - (send (ethernet-packet gw-if - #f - (ethernet-interface-hwaddr gw-if) - (gateway-route-state-gateway-hwaddr s) - IPv4-ethertype - (format-ip-packet p)))))] + (message (ethernet-packet gw-if + #f + (ethernet-interface-hwaddr gw-if) + (gateway-route-state-gateway-hwaddr s) + IPv4-ethertype + (format-ip-packet p)))))] [_ #f])) (gateway-route-state (set) #f #f) - (gestalt-union gestalt-for-supply - - (sub (ip-packet ? ? ? ? ? ?)) - (pub (ip-packet ? ? ? ? ? ?)) - - observe-local-ip-addresses-gestalt - (sub (net-route ? ? ?) #:level 2) - (sub (gateway-route ? ? ? ?) #:level 2) - (projection->gestalt gateway-arp-projector)))) + (scn/union (subscription the-route) + (assertion (route-up the-route)) + (subscription (ip-packet ? ? ? ? ? ?)) + observe-local-ip-addresses-gestalt + (subscription (net-route ? ? ?)) + (subscription (gateway-route ? ? ? ?)) + (subscription (projection->pattern gateway-arp-projector))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; General net route (define (spawn-net-route network-addr netmask link) - (spawn-normal-ip-route (net-route-supply network-addr netmask link) network-addr netmask link)) + (spawn-normal-ip-route (net-route network-addr netmask link) network-addr netmask link)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Normal IP route -(define (spawn-normal-ip-route gestalt-for-supply network netmask interface-name) +(define (spawn-normal-ip-route the-route network netmask interface-name) (spawn (lambda (e s) (match e - [(routing-update g) - (transition s (when (gestalt-empty? g) (quit)))] - [(message (ethernet-packet _ _ _ _ _ body) _ _) + [(scn (? trie-empty?)) (quit)] + [(message (ethernet-packet _ _ _ _ _ body)) (define p (parse-ip-packet interface-name body)) - (and p (transition s (send p)))] - [(message (? ip-packet? p) _ _) + (and p (transition s (message p)))] + [(message (? ip-packet? p)) (define destination (ip-packet-destination p)) (and (not (equal? (ip-packet-source-interface p) interface-name)) (ip-address-in-subnet? destination network netmask) @@ -224,23 +214,21 @@ s (lookup-arp destination (ethernet-interface interface-name ?) - (gestalt-empty) + (trie-empty) (lambda (interface destination-hwaddr) - (send (ethernet-packet interface - #f - (ethernet-interface-hwaddr interface) - destination-hwaddr - IPv4-ethertype - (format-ip-packet p)))))))] + (message (ethernet-packet interface + #f + (ethernet-interface-hwaddr interface) + destination-hwaddr + IPv4-ethertype + (format-ip-packet p)))))))] [_ #f])) (void) - (gestalt-union gestalt-for-supply - (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)) - (pub (arp-interface interface-name)) - (sub (ip-packet ? ? ? ? ? ?)) - (pub (ip-packet ? ? ? ? ? ?))))) + (scn/union (subscription the-route) + (assertion (route-up the-route)) + (subscription (ethernet-packet-pattern interface-name #t IPv4-ethertype)) + (assertion (arp-interface interface-name)) + (subscription (ip-packet ? ? ? ? ? ?))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -313,25 +301,25 @@ full-packet) (define (lookup-arp ipaddr query-interface-pattern base-gestalt k) - (on-gestalt (lambda (_g arp-results) - (if (not arp-results) - (error 'ip "Someone has published a wildcard arp result") - (and (not (set-empty? arp-results)) - (match (set-first arp-results) - [(list interface hwaddr) - (log-info "ARP lookup yielded ~a on ~a for ~a" - (pretty-bytes hwaddr) - (ethernet-interface-name interface) - (ip-address->hostname ipaddr)) - (when (> (set-count arp-results) 1) - (log-warning "Ambiguous ARP result for ~a: ~v" - (ip-address->hostname ipaddr) - arp-results)) - (k interface hwaddr)])))) - base-gestalt - (project-pubs (arp-query IPv4-ethertype ipaddr (?! query-interface-pattern) (?!))) - #:timeout-msec 5000 - #:on-timeout (lambda () - (log-warning "ARP lookup of ~a failed, packet dropped" - (ip-address->hostname ipaddr)) - '()))) + (on-claim (lambda (_g arp-results) + (if (not arp-results) + (error 'ip "Someone has published a wildcard arp result") + (and (not (set-empty? arp-results)) + (match (set-first arp-results) + [(list interface hwaddr) + (log-info "ARP lookup yielded ~a on ~a for ~a" + (pretty-bytes hwaddr) + (ethernet-interface-name interface) + (ip-address->hostname ipaddr)) + (when (> (set-count arp-results) 1) + (log-warning "Ambiguous ARP result for ~a: ~v" + (ip-address->hostname ipaddr) + arp-results)) + (k interface hwaddr)])))) + base-gestalt + (arp-query IPv4-ethertype ipaddr (?! query-interface-pattern) (?!)) + #:timeout-msec 5000 + #:on-timeout (lambda () + (log-warning "ARP lookup of ~a failed, packet dropped" + (ip-address->hostname ipaddr)) + '()))) diff --git a/main.rkt b/main.rkt index af9d6af..8feeb27 100644 --- a/main.rkt +++ b/main.rkt @@ -1,13 +1,13 @@ -#lang minimart +#lang prospect-monolithic -(require minimart/demand-matcher) -(require minimart/drivers/timer) +(require prospect-monolithic/demand-matcher) +(require prospect-monolithic/drivers/timer) (require "demo-config.rkt") (require "ethernet.rkt") (require "arp.rkt") (require "ip.rkt") -(require "tcp.rkt") -(require "udp.rkt") +;; (require "tcp.rkt") +;; (require "udp.rkt") ;;(log-events-and-actions? #t) @@ -15,94 +15,95 @@ (spawn-ethernet-driver) (spawn-arp-driver) (spawn-ip-driver) -(spawn-tcp-driver) -(spawn-udp-driver) +;; (spawn-tcp-driver) +;; (spawn-udp-driver) (spawn-demo-config) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(let () +#;(let () (local-require racket/set racket/string) (define (spawn-session them us) (define user (gensym 'user)) - (define remote-detector (project-pubs #:meta-level 1 (?!))) - (define peer-detector (project-pubs `(,(?!) says ,?))) + (define remote-detector (compile-projection (at-meta (?!)))) + (define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) (define (send-to-remote fmt . vs) - (send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))) + (message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (define (say who fmt . vs) (unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs)))) (list (send-to-remote "Welcome, ~a.\n" user) - (spawn (lambda (e old-peers) - (log-info "~a: ~v --> ~v" user e old-peers) - (match e - [(message (tcp-channel _ _ bs) 1 #f) - (transition old-peers - (send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))] - [(message `(,who says ,what) 0 #f) - (transition old-peers (say who "says: ~a" what))] - [(routing-update g) - (define new-peers (gestalt-project/single g peer-detector)) - (transition - new-peers - (list (when (matcher-empty? (gestalt-project g remote-detector)) (quit)) - (for/list [(who (set-subtract new-peers old-peers))] - (say who "arrived.")) - (for/list [(who (set-subtract old-peers new-peers))] - (say who "departed."))))] - [#f #f])) - (set) - (gestalt-union (sub `(,? says ,?)) - (sub `(,? says ,?) #:level 1) - (pub `(,user says ,?)) - (sub (tcp-channel them us ?) #:meta-level 1) - (sub (tcp-channel them us ?) #:meta-level 1 #:level 1) - (pub (tcp-channel us them ?) #:meta-level 1))))) - - (spawn-world - (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 6667)) ?) - #:meta-level 1 - spawn-session)) + (spawn + (lambda (e peers) + (match e + [(message (at-meta (tcp-channel _ _ bs))) + (transition peers (message `(,user says ,(string-trim (bytes->string/utf-8 bs)))))] + [(message `(,who says ,what)) + (transition peers (say who "says: ~a" what))] + [(scn assertions) + (if (trie-empty? (trie-project assertions remote-detector)) + (quit (send-to-remote "Goodbye!\n")) + (let ((new-peers (trie-project/set/single assertions peer-detector))) + (define arrived (set-subtract new-peers peers)) + (define departed (set-subtract peers new-peers)) + (transition new-peers + (list (for/list [(who arrived)] (say who "arrived.")) + (for/list [(who departed)] (say who "departed."))))))] + [#f #f])) + (set) + (scn/union + (subscription `(,? says ,?)) ;; read actual chat messages + (subscription (advertise `(,? says ,?))) ;; observe peer presence + (advertisement `(,user says ,?)) ;; advertise our presence + (subscription (tcp-channel them us ?) #:meta-level 1) ;; read from remote client + (subscription (advertise (tcp-channel them us ?)) #:meta-level 1) ;; monitor remote client + (advertisement (tcp-channel us them ?) #:meta-level 1) ;; we will write to remote client + )))) + (spawn-demand-matcher (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?)) + (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?)) + #:meta-level 1 + spawn-session) ) -(let () +#;(let () (spawn (lambda (e s) (match e - [(message (udp-packet src dst body) _ _) + [(message (udp-packet src dst body)) (log-info "Got packet from ~v: ~v" src body) - (transition s (send (udp-packet dst - src - (string->bytes/utf-8 (format "You said: ~a" body)))))] + (transition s (message + (udp-packet dst + src + (string->bytes/utf-8 (format "You said: ~a" body)))))] [_ #f])) (void) - (gestalt-union (sub (udp-packet ? (udp-listener 6667) ?))))) + (scn (subscription (udp-packet ? (udp-listener 6667) ?))))) -(let () +#;(let () (define (spawn-session them us) (list (send 'bump) (spawn (lambda (e s) (match e - [(message `(counter ,counter) _ _) + [(message `(counter ,counter)) (define response (string->bytes/utf-8 (format (string-append "HTTP/1.0 200 OK\r\n\r\n" - "

Hello world from minimart-netstack!

\n" - "

This is running on minimart's own\n" - "\n" + "

Hello world from prospect-monolithic-netstack!

\n" + "

This is running on prospect-monolithic's own\n" + "\n" "TCP/IP stack.

\n" "

There have been ~a requests prior to this one.

") counter))) - (transition s (list (send #:meta-level 1 (tcp-channel us them response)) + (transition s (list (message #:meta-level 1 (tcp-channel us them response)) (quit)))] [_ #f])) (void) - (gestalt-union (sub `(counter ,?)) - (sub (tcp-channel them us ?) #:meta-level 1) - (sub (tcp-channel them us ?) #:meta-level 1 #:level 1) - (pub (tcp-channel us them ?) #:meta-level 1))))) + (scn/union (subscription `(counter ,?)) + (subscription (tcp-channel them us ?) #:meta-level 1) + (subscription (advertise (tcp-channel them us ?)) #:meta-level 1) + (advertisement (tcp-channel us them ?) #:meta-level 1))))) (spawn-world (spawn (lambda (e counter) @@ -111,30 +112,10 @@ (transition (+ counter 1) (send `(counter ,counter)))] [_ #f])) 0 - (gestalt-union (sub 'bump) - (pub `(counter ,?)))) - (spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?) + (scn (subscription 'bump))) + (spawn-demand-matcher (advertise (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?)) + (observe (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?)) #:meta-level 1 spawn-session)) ) - -(spawn (lambda (e s) - (local-require racket/pretty) - (match e - [(message m _ _) - ;; (pretty-write `(MAIN ,m)) - (void)] - [(routing-update g) - ;; (printf "MAIN gestalt:\n") - ;; (pretty-print-gestalt g) - (void)] - [_ (void)]) - (flush-output) - #f) - (void) - (gestalt-union - (sub ? #:level 5) - (pub ? #:level 5) - ;;(sub (tcp-channel ? ? ?) #:level 5) - )) diff --git a/port-allocator.rkt b/port-allocator.rkt index 6466db3..1599cd5 100644 --- a/port-allocator.rkt +++ b/port-allocator.rkt @@ -6,7 +6,7 @@ (require racket/set) (require racket/match) -(require minimart) +(require prospect-monolithic) (require "ip.rkt") (struct port-allocation-request (type k) #:prefab) diff --git a/tcp.rkt b/tcp.rkt index 2f5df59..e6525be 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -8,9 +8,9 @@ (require racket/set) (require racket/match) -(require minimart) -(require minimart/drivers/timer) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/drivers/timer) +(require prospect-monolithic/demand-matcher) (require bitsyntax) (require "dump-bytes.rkt") diff --git a/udp.rkt b/udp.rkt index a2444c5..d275571 100644 --- a/udp.rkt +++ b/udp.rkt @@ -10,8 +10,8 @@ (require racket/set) (require racket/match) -(require minimart) -(require minimart/demand-matcher) +(require prospect-monolithic) +(require prospect-monolithic/demand-matcher) (require bitsyntax) (require "dump-bytes.rkt") From 279e2739090acda4efe3d5bca727a2317ebe6792 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 23 Jan 2016 20:12:05 -0500 Subject: [PATCH 55/70] Makefile --- Makefile | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 Makefile diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..05a045c --- /dev/null +++ b/Makefile @@ -0,0 +1,7 @@ +all: + +run: + racketmake main.rkt + +clean: + find . -name compiled -type d | xargs rm -rf From 54067dbeac704d7d4140bf872f8105f2a74f7aa5 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 23 Jan 2016 20:17:03 -0500 Subject: [PATCH 56/70] Fix gateway ARP lookup --- ip.rkt | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/ip.rkt b/ip.rkt index 3e98837..4411023 100644 --- a/ip.rkt +++ b/ip.rkt @@ -130,11 +130,10 @@ (define host-route-projector (compile-projection (host-route (?!) ? ?))) (define gateway-route-projector (compile-projection (gateway-route (?!) (?!) ? ?))) (define net-route-projector (compile-projection (net-route (?!) (?!) ?))) - (define gateway-arp-projector (compile-projection - (arp-query IPv4-ethertype - gateway-addr - (?! (ethernet-interface interface-name ?)) - (?!)))) + (define gateway-arp-projector (arp-query IPv4-ethertype + gateway-addr + (?! (ethernet-interface interface-name ?)) + (?!))) (define (covered-by-some-other-route? addr routes) (for/or ([r (in-set routes)]) @@ -148,8 +147,9 @@ (define host-ips (trie-project/set/single g host-route-projector)) (define gw-nets+netmasks (trie-project/set g gateway-route-projector)) (define net-nets+netmasks (trie-project/set g net-route-projector)) - (define gw-ip+hwaddr (let ((vs (trie-project/set g gateway-arp-projector))) - (and vs (not (set-empty? vs)) (set-first vs)))) + (define gw-ip+hwaddr + (let ((vs (trie-project/set g (compile-projection gateway-arp-projector)))) + (and vs (not (set-empty? vs)) (set-first vs)))) (when (and gw-ip+hwaddr (not (gateway-route-state-gateway-hwaddr s))) (log-info "Discovered gateway ~a at ~a on interface ~a." (ip-address->hostname gateway-addr) From 6a449648e32849228254e7f1533196a9bc4ff468 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 23 Jan 2016 21:50:39 -0500 Subject: [PATCH 57/70] Use host-route netmask in gateway outbound relay. I'm not sure why previously it had been hardcoded to a 32-bit netmask; presumably this was an error on my part way back in the original routing implementation in minimart-netstack. It looks as if the code was originally written for a kind of host route that didn't have a netmask, and was never updated to include the netmask later. --- ip.rkt | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/ip.rkt b/ip.rkt index 4411023..7166647 100644 --- a/ip.rkt +++ b/ip.rkt @@ -127,7 +127,7 @@ (define (spawn-gateway-route network netmask gateway-addr interface-name) (define the-route (gateway-route network netmask gateway-addr interface-name)) - (define host-route-projector (compile-projection (host-route (?!) ? ?))) + (define host-route-projector (compile-projection (host-route (?!) (?!) ?))) (define gateway-route-projector (compile-projection (gateway-route (?!) (?!) ? ?))) (define net-route-projector (compile-projection (net-route (?!) (?!) ?))) (define gateway-arp-projector (arp-query IPv4-ethertype @@ -144,7 +144,7 @@ (spawn (lambda (e s) (match e [(scn g) - (define host-ips (trie-project/set/single g host-route-projector)) + (define host-ips+netmasks (trie-project/set g host-route-projector)) (define gw-nets+netmasks (trie-project/set g gateway-route-projector)) (define net-nets+netmasks (trie-project/set g net-route-projector)) (define gw-ip+hwaddr @@ -158,7 +158,7 @@ (if (trie-empty? (project-assertions g (?! the-route))) (quit) (transition (gateway-route-state - (set-union (for/set ([ip host-ips]) (list ip 32)) + (set-union host-ips+netmasks gw-nets+netmasks net-nets+netmasks) (and gw-ip+hwaddr (car gw-ip+hwaddr)) From aabeb5adcde7c6a7a6ce7c29b2fde874ec52322c Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 23 Jan 2016 21:59:33 -0500 Subject: [PATCH 58/70] UDP. --- main.rkt | 6 +-- port-allocator.rkt | 11 ++--- udp.rkt | 112 ++++++++++++++++++++++----------------------- 3 files changed, 64 insertions(+), 65 deletions(-) diff --git a/main.rkt b/main.rkt index 8feeb27..cb6a11c 100644 --- a/main.rkt +++ b/main.rkt @@ -7,7 +7,7 @@ (require "arp.rkt") (require "ip.rkt") ;; (require "tcp.rkt") -;; (require "udp.rkt") +(require "udp.rkt") ;;(log-events-and-actions? #t) @@ -16,7 +16,7 @@ (spawn-arp-driver) (spawn-ip-driver) ;; (spawn-tcp-driver) -;; (spawn-udp-driver) +(spawn-udp-driver) (spawn-demo-config) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -66,7 +66,7 @@ spawn-session) ) -#;(let () +(let () (spawn (lambda (e s) (match e [(message (udp-packet src dst body)) diff --git a/port-allocator.rkt b/port-allocator.rkt index 1599cd5..533a9e4 100644 --- a/port-allocator.rkt +++ b/port-allocator.rkt @@ -16,12 +16,12 @@ (define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports) (spawn (lambda (e s) (match e - [(routing-update g) + [(scn g) (define local-ips (or (gestalt->local-ip-addresses g) (set))) (define new-used-ports (compute-used-ports g local-ips)) (log-info "port-allocator ~v used ports: ~v" allocator-type new-used-ports) (transition (port-allocator-state new-used-ports local-ips) '())] - [(message (port-allocation-request _ k) _ _) + [(message (port-allocation-request _ k)) (define currently-used-ports (port-allocator-state-used-ports s)) (let randomly-allocate-until-unused () (define p (+ 1024 (random 64512))) @@ -32,7 +32,6 @@ (k p (port-allocator-state-local-ips s)))))] [_ #f])) (port-allocator-state (set) (set)) - (apply gestalt-union - (sub (port-allocation-request allocator-type ?)) - observe-local-ip-addresses-gestalt - observer-gestalt))) + (scn/union (subscription (port-allocation-request allocator-type ?)) + observe-local-ip-addresses-gestalt + observer-gestalt))) diff --git a/udp.rkt b/udp.rkt index d275571..d1302ae 100644 --- a/udp.rkt +++ b/udp.rkt @@ -43,6 +43,7 @@ ;; KERNEL-level protocol (struct udp-datagram (source-ip source-port destination-ip destination-port body) #:prefab) +(struct udp-port-allocation (port handle) #:prefab) ;; (udp-port-allocation Number UdpLocalAddress) (define any-remote (udp-remote-address ? ?)) @@ -51,26 +52,24 @@ (define (spawn-udp-driver) (list - (spawn-demand-matcher (udp-packet ? (?! (udp-listener ?)) ?) - #:demand-is-subscription? #t + (spawn-demand-matcher (observe (udp-packet ? (?! (udp-listener ?)) ?)) + (advertise (udp-packet ? (?! (udp-listener ?)) ?)) (lambda (handle) (spawn-udp-relay (udp-listener-port handle) handle))) - (spawn-demand-matcher (udp-packet ? (?! (udp-handle ?)) ?) - #:demand-is-subscription? #t + (spawn-demand-matcher (observe (udp-packet ? (?! (udp-handle ?)) ?)) + (advertise (udp-packet ? (?! (udp-handle ?)) ?)) (lambda (handle) - (send (port-allocation-request - 'udp - (lambda (port local-ips) (spawn-udp-relay port handle)))))) + (message (port-allocation-request + 'udp + (lambda (port local-ips) (spawn-udp-relay port handle)))))) (spawn-udp-port-allocator) (spawn-kernel-udp-driver))) (define (spawn-udp-port-allocator) - (define udp-projector (project-pubs (udp-datagram (?!) (?!) ? ? ?))) + (define udp-projector (udp-port-allocation (?!) ?)) (spawn-port-allocator 'udp - (list (projection->gestalt udp-projector)) + (subscription (projection->pattern udp-projector)) (lambda (g local-ips) - (for/set [(e (gestalt-project/keys g udp-projector)) - #:when (set-member? local-ips (car e))] - (cadr e))))) + (project-assertions g udp-projector)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Relaying @@ -78,44 +77,45 @@ (define (spawn-udp-relay local-port local-user-addr) (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr) - (define local-peer-gestalt (pub (udp-packet any-remote local-user-addr ?) #:level 1)) + (define local-peer-detector (?! (observe (udp-packet any-remote local-user-addr ?)))) (define (compute-gestalt local-ips) - (for/fold [(g (gestalt-union local-peer-gestalt - observe-local-ip-addresses-gestalt - (pub (udp-packet any-remote local-user-addr ?)) - (sub (udp-packet local-user-addr any-remote ?))))] - [(ip (in-set local-ips))] - (gestalt-union g - (sub (udp-datagram ? ? ip local-port ?)) - (pub (udp-datagram ip local-port ? ? ?))))) + (for/fold [(g (assertion-set-union + (subscription (projection->pattern local-peer-detector)) + (advertisement (udp-packet any-remote local-user-addr ?)) + observe-local-ip-addresses-gestalt + (subscription (udp-packet local-user-addr any-remote ?)) + (assertion (udp-port-allocation local-port local-user-addr))))] + [(ip (in-set local-ips))] + (assertion-set-union g + (subscription (udp-datagram ? ? ip local-port ?)) + (advertisement (udp-datagram ip local-port ? ? ?))))) (spawn (lambda (e local-ips) (match e - [(routing-update g) + [(scn g) (define new-local-ips (gestalt->local-ip-addresses g)) - (transition new-local-ips - (list - (when (gestalt-empty? (gestalt-filter g local-peer-gestalt)) (quit)) - (routing-update (compute-gestalt new-local-ips))))] - [(message (udp-packet (== local-user-addr) remote-addr bs) _ _) + (if (trie-empty? (trie-project g (compile-projection local-peer-detector))) + (quit) + (transition new-local-ips (scn (compute-gestalt new-local-ips))))] + [(message (udp-packet (== local-user-addr) remote-addr bs)) ;; Choose arbitrary local IP address for outbound packet! ;; TODO: what can be done? Must I examine the routing table? (match-define (udp-remote-address remote-host remote-port) remote-addr) (define remote-ip (ip-string->ip-address remote-host)) - (transition local-ips (send (udp-datagram (set-first local-ips) - local-port - remote-ip - remote-port - bs)))] - [(message (udp-datagram si sp _ _ bs) _ _) - (transition local-ips (send (udp-packet (udp-remote-address (ip-address->hostname si) - sp) - local-user-addr - bs)))] + (transition local-ips (message (udp-datagram (set-first local-ips) + local-port + remote-ip + remote-port + bs)))] + [(message (udp-datagram si sp _ _ bs)) + (transition local-ips + (message (udp-packet (udp-remote-address (ip-address->hostname si) sp) + local-user-addr + bs)))] [_ #f])) (set) - (compute-gestalt (set)))) + (scn (compute-gestalt (set))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Codec & kernel-level driver @@ -125,9 +125,9 @@ (define (spawn-kernel-udp-driver) (spawn (lambda (e local-ips) (match e - [(routing-update g) + [(scn g) (transition (gestalt->local-ip-addresses g) '())] - [(message (ip-packet source-if src-ip dst-ip _ _ body) _ _) + [(message (ip-packet source-if src-ip dst-ip _ _ body)) #:when (and source-if (set-member? local-ips dst-ip)) (bit-string-case body ([ (src-port :: integer bytes 2) @@ -138,14 +138,14 @@ (bit-string-case data ([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes (:: binary) ] - (transition local-ips (send (udp-datagram src-ip - src-port - dst-ip - dst-port - (bit-string->bytes payload))))) + (transition local-ips (message (udp-datagram src-ip + src-port + dst-ip + dst-port + (bit-string->bytes payload))))) (else #f))) (else #f))] - [(message (udp-datagram src-ip src-port dst-ip dst-port bs) _ _) + [(message (udp-datagram src-ip src-port dst-ip dst-port bs)) #:when (set-member? local-ips src-ip) (let* ((payload (bit-string (src-port :: integer bytes 2) (dst-port :: integer bytes 2) @@ -161,15 +161,15 @@ :: integer bytes 2))) (checksummed-payload (ip-checksum #:pseudo-header pseudo-header 6 payload))) - (transition local-ips (send (ip-packet #f - src-ip - dst-ip - PROTOCOL-UDP - #"" - checksummed-payload))))] + (transition local-ips (message (ip-packet #f + src-ip + dst-ip + PROTOCOL-UDP + #"" + checksummed-payload))))] [_ #f])) (set) - (gestalt-union (pub (ip-packet #f ? ? PROTOCOL-UDP ? ?)) - (sub (ip-packet ? ? ? PROTOCOL-UDP ? ?)) - (sub (udp-datagram ? ? ? ? ?)) - observe-local-ip-addresses-gestalt))) + (scn/union (advertisement (ip-packet #f ? ? PROTOCOL-UDP ? ?)) + (subscription (ip-packet ? ? ? PROTOCOL-UDP ? ?)) + (subscription (udp-datagram ? ? ? ? ?)) + observe-local-ip-addresses-gestalt))) From 0206dec737c49a8f9bab01a9d1a162f3273faf21 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 23 Jan 2016 22:57:07 -0500 Subject: [PATCH 59/70] TCP. Connection & transfer works; disconnection, not. --- main.rkt | 15 ++-- tcp.rkt | 256 ++++++++++++++++++++++++++++--------------------------- 2 files changed, 137 insertions(+), 134 deletions(-) diff --git a/main.rkt b/main.rkt index cb6a11c..9d7828c 100644 --- a/main.rkt +++ b/main.rkt @@ -6,7 +6,7 @@ (require "ethernet.rkt") (require "arp.rkt") (require "ip.rkt") -;; (require "tcp.rkt") +(require "tcp.rkt") (require "udp.rkt") ;;(log-events-and-actions? #t) @@ -15,13 +15,13 @@ (spawn-ethernet-driver) (spawn-arp-driver) (spawn-ip-driver) -;; (spawn-tcp-driver) +(spawn-tcp-driver) (spawn-udp-driver) (spawn-demo-config) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -#;(let () +(let () (local-require racket/set racket/string) (define (spawn-session them us) @@ -60,10 +60,11 @@ (advertisement (tcp-channel us them ?) #:meta-level 1) ;; we will write to remote client )))) - (spawn-demand-matcher (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?)) - (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?)) - #:meta-level 1 - spawn-session) + (spawn-network + (spawn-demand-matcher (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?)) + (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?)) + #:meta-level 1 + spawn-session)) ) (let () diff --git a/tcp.rkt b/tcp.rkt index e6525be..876c2e7 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -44,22 +44,32 @@ data) #:prefab) +;; (tcp-port-allocation Number (U TcpHandle TcpListener)) +(struct tcp-port-allocation (port handle) #:prefab) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User-accessible driver startup (define (spawn-tcp-driver) - (list (spawn-demand-matcher (tcp-channel ? (?! (tcp-listener ?)) ?) - #:demand-is-subscription? #t - #:demand-level 1 - #:supply-level 2 + (list (spawn-demand-matcher (advertise (observe (tcp-channel ? (?! (tcp-listener ?)) ?))) + (advertise (advertise (tcp-channel ? (?! (tcp-listener ?)) ?))) (lambda (server-addr) (match-define (tcp-listener port) server-addr) ;; TODO: have listener shut down once user-level listener does + (spawn (lambda (e s) #f) + (void) + (assertion (tcp-port-allocation port server-addr))) (spawn-demand-matcher - (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-address ? port)) ?) + (advertise (tcp-channel (?! (tcp-address ? ?)) + (?! (tcp-address ? port)) + ?)) + (observe (tcp-channel (?! (tcp-address ? ?)) + (?! (tcp-address ? port)) + ?)) (spawn-relay server-addr)))) - (spawn-demand-matcher (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?) - allocate-port-and-spawn-socket) + (spawn-demand-matcher (advertise (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?)) + (observe (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?)) + allocate-port-and-spawn-socket) (spawn-tcp-port-allocator) (spawn-kernel-tcp-driver))) @@ -67,44 +77,32 @@ ;; Port allocation (define (spawn-tcp-port-allocator) - (define project-active-connections (project-pubs (tcp-packet #f (?!) (?!) ? ? ? ? ? ? ? ?))) - ;; We have to have gestalt observing listeners at level 3 so that - ;; we're not mistaken for listener supply! We still project out at - ;; level 1 (instead of level 2, as would be natural for a level 3 - ;; observer gestalt) though. - (define listeners-p (project-subs #:level 1 (tcp-channel ? (tcp-listener (?!)) ?))) - (define listeners-g (pub #:level 3 (tcp-channel ? (tcp-listener ?) ?))) (spawn-port-allocator 'tcp - (list (projection->gestalt project-active-connections) listeners-g) + (subscription (tcp-port-allocation ? ?)) (lambda (g local-ips) - (define listener-ports (gestalt-project/single g listeners-p)) - (define active-connection-ports - (for/set [(e (gestalt-project/keys g project-active-connections)) - #:when (set-member? local-ips (car e))] - (cadr e))) - (set-union listener-ports active-connection-ports)))) + (project-assertions g (tcp-port-allocation (?!) ?))))) (define (allocate-port-and-spawn-socket local-addr remote-addr) - (send (port-allocation-request - 'tcp - (lambda (port local-ips) - ;; TODO: Choose a sensible IP address for the outbound - ;; connection. We don't have enough information to do this - ;; well at the moment, so just pick some available local IP - ;; address. - ;; - ;; Interesting note: In some sense, the right answer is - ;; "?". This would give us a form of mobility, where IP - ;; addresses only route to a given bucket-of-state and ONLY - ;; the port number selects a substate therein. That's not - ;; how TCP is defined however so we can't do that. - (define appropriate-ip (set-first local-ips)) - (define appropriate-host (ip-address->hostname appropriate-ip)) - (match-define (tcp-address remote-host remote-port) remote-addr) - (define remote-ip (ip-string->ip-address remote-host)) - (list - ((spawn-relay local-addr) remote-addr (tcp-address appropriate-host port)) - (spawn-state-vector remote-ip remote-port appropriate-ip port)))))) + (message (port-allocation-request + 'tcp + (lambda (port local-ips) + ;; TODO: Choose a sensible IP address for the outbound + ;; connection. We don't have enough information to do this + ;; well at the moment, so just pick some available local IP + ;; address. + ;; + ;; Interesting note: In some sense, the right answer is + ;; "?". This would give us a form of mobility, where IP + ;; addresses only route to a given bucket-of-state and ONLY + ;; the port number selects a substate therein. That's not + ;; how TCP is defined however so we can't do that. + (define appropriate-ip (set-first local-ips)) + (define appropriate-host (ip-address->hostname appropriate-ip)) + (match-define (tcp-address remote-host remote-port) remote-addr) + (define remote-ip (ip-string->ip-address remote-host)) + (list + ((spawn-relay local-addr) remote-addr (tcp-address appropriate-host port)) + (spawn-state-vector remote-ip remote-port appropriate-ip port)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Relay between kernel-level and user-level @@ -113,33 +111,40 @@ (define ((spawn-relay local-user-addr) remote-addr local-tcp-addr) (define timer-name (list 'spawn-relay local-tcp-addr remote-addr)) - (define local-peer-traffic (pub (tcp-channel remote-addr local-user-addr ?) #:level 1)) - (define remote-peer-traffic (sub (tcp-channel remote-addr local-tcp-addr ?) #:level 1)) + (define local-peer-traffic (?! (observe (tcp-channel remote-addr local-user-addr ?)))) + (define remote-peer-traffic (?! (advertise (tcp-channel remote-addr local-tcp-addr ?)))) (list - (send (set-timer timer-name relay-peer-wait-time-msec 'relative)) + (message (set-timer timer-name relay-peer-wait-time-msec 'relative)) (spawn (lambda (e state) (match e - [(routing-update g) - (define local-peer-absent? (gestalt-empty? (gestalt-filter g local-peer-traffic))) - (define remote-peer-absent? (gestalt-empty? (gestalt-filter g remote-peer-traffic))) + [(scn g) + (define local-peer-absent? + (trie-empty? (trie-project g (compile-projection local-peer-traffic)))) + (define remote-peer-absent? + (trie-empty? (trie-project g (compile-projection remote-peer-traffic)))) (define new-state (+ (if local-peer-absent? 0 1) (if remote-peer-absent? 0 1))) - (transition new-state (when (< new-state state) (quit)))] - [(message (tcp-channel (== local-user-addr) (== remote-addr) bs) _ _) - (transition state (send (tcp-channel local-tcp-addr remote-addr bs)))] - [(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs) _ _) - (transition state (send (tcp-channel remote-addr local-user-addr bs)))] - [(message (timer-expired _ _) _ _) + (if (< new-state state) + (quit) + (transition new-state '()))] + [(message (tcp-channel (== local-user-addr) (== remote-addr) bs)) + (transition state (message (tcp-channel local-tcp-addr remote-addr bs)))] + [(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs)) + (transition state (message (tcp-channel remote-addr local-user-addr bs)))] + [(message (timer-expired _ _)) #:when (< state 2) ;; we only care if we're not fully connected (error 'spawn-relay "TCP relay process timed out waiting for peer")] [_ #f])) 0 - (gestalt-union local-peer-traffic - remote-peer-traffic - (sub (tcp-channel remote-addr local-tcp-addr ?)) - (sub (tcp-channel local-user-addr remote-addr ?)) - (pub (tcp-channel remote-addr local-user-addr ?)) - (pub (tcp-channel local-tcp-addr remote-addr ?)) - (sub (timer-expired timer-name ?)))))) + (scn/union (subscription (projection->pattern local-peer-traffic)) + (subscription (projection->pattern remote-peer-traffic)) + (assertion (tcp-port-allocation (tcp-address-port local-tcp-addr) + local-user-addr)) + (subscription (tcp-channel remote-addr local-tcp-addr ?)) + (subscription (tcp-channel local-user-addr remote-addr ?)) + (advertisement (tcp-channel remote-addr local-user-addr ?)) + (advertisement (tcp-channel local-tcp-addr remote-addr ?)) + (subscription (timer-expired timer-name ?)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Codec & kernel-level driver @@ -215,15 +220,16 @@ (when spawn-needed? (spawn-state-vector src-ip src-port dst-ip dst-port)) ;; TODO: get packet to the new state-vector process somehow - (send packet))))) + (message packet))))) (else #f)))) (else #f))) - (define statevec-projection (project-subs (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?))) + (define statevec-projection + (compile-projection (observe (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?)))) (define (analyze-gestalt g s) (define local-ips (gestalt->local-ip-addresses g)) - (define statevecs (gestalt-project/keys g statevec-projection)) + (define statevecs (trie-project/set g statevec-projection)) (log-info "gestalt yielded statevecs ~v and local-ips ~v" statevecs local-ips) (transition (struct-copy codec-state s [local-ips local-ips] @@ -277,27 +283,26 @@ 0 PROTOCOL-TCP ((bit-string-byte-count payload) :: integer bytes 2))) - (transition s (send (ip-packet #f src-ip dst-ip PROTOCOL-TCP #"" - (ip-checksum 16 payload #:pseudo-header pseudo-header))))) + (transition s (message (ip-packet #f src-ip dst-ip PROTOCOL-TCP #"" + (ip-checksum 16 payload #:pseudo-header pseudo-header))))) (spawn (lambda (e s) (match e - [(routing-update g) + [(scn g) (analyze-gestalt g s)] - [(message (ip-packet source-if src dst _ _ body) _ _) + [(message (ip-packet source-if src dst _ _ body)) #:when (and source-if ;; source-if == #f iff packet originates locally (set-member? (codec-state-local-ips s) dst)) (analyze-incoming-packet src dst body s)] - [(message (? tcp-packet? p) _ _) + [(message (? tcp-packet? p)) #:when (not (tcp-packet-from-wire? p)) (deliver-outbound-packet p s)] [_ #f])) (codec-state (set) (set)) - (gestalt-union (pub (ip-packet #f ? ? PROTOCOL-TCP ? ?)) - (sub (ip-packet ? ? ? PROTOCOL-TCP ? ?)) - (sub (tcp-packet #f ? ? ? ? ? ? ? ? ? ?)) - (pub (tcp-packet #t ? ? ? ? ? ? ? ? ? ?) #:level 1) - observe-local-ip-addresses-gestalt))) + (scn/union (subscription (ip-packet ? ? ? PROTOCOL-TCP ? ?)) + (subscription (tcp-packet #f ? ? ? ? ? ? ? ? ? ?)) + (subscription (observe (tcp-packet #t ? ? ? ? ? ? ? ? ? ?))) + observe-local-ip-addresses-gestalt))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Per-connection state vector process @@ -359,27 +364,25 @@ (define (seq> a b) (< (seq- a b) #x80000000)) - (define local-peer-detector (pub (tcp-channel src dst ?) #:level 1)) - (define listener-detector (pub (tcp-channel ? (tcp-listener dst-port) ?) #:level 3)) - ;; ^ see comment in spawn-tcp-port-allocator for why level 3 instead of level 2 + (define local-peer-detector (?! (observe (tcp-channel src dst ?)))) + (define listener-detector (?! (observe (advertise (tcp-channel ? (tcp-listener dst-port) ?))))) ;; ConnState -> Gestalt (define (compute-gestalt s) (define worldward-facing-gestalt - (gestalt-union (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?)) - (pub (tcp-packet #f dst-ip dst-port src-ip src-port ? ? ? ? ? ?)))) + (subscription (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?))) (define appward-facing-gestalt - (gestalt-union - local-peer-detector - listener-detector - (sub (tcp-channel dst src ?)) + (assertion-set-union + (subscription (projection->pattern local-peer-detector)) + (subscription (projection->pattern listener-detector)) + (subscription (tcp-channel dst src ?)) (if (and (conn-state-syn-acked? s) (not (buffer-finished? (conn-state-inbound s)))) - (pub (tcp-channel src dst ?)) - (gestalt-empty)))) - (gestalt-union (sub (timer-expired (timer-name ?) ?)) - worldward-facing-gestalt - appward-facing-gestalt)) + (advertisement (tcp-channel src dst ?)) + (trie-empty)))) + (assertion-set-union (subscription (timer-expired (timer-name ?) ?)) + worldward-facing-gestalt + appward-facing-gestalt)) ;; ConnState -> Transition (define (deliver-inbound-locally s) @@ -391,7 +394,7 @@ [inbound (struct-copy buffer b [data #""] [seqn (seq+ (buffer-seqn b) (bytes-length chunk))])]) - (send (tcp-channel src dst chunk)))))) + (message (tcp-channel src dst chunk)))))) ;; (Setof Symbol) -> ConnState -> Transition (define ((check-fin flags) s) @@ -404,7 +407,7 @@ [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte [finished? #t])]))) (log-info "Closing inbound stream.") - (transition new-s (routing-update (compute-gestalt new-s)))) + (transition new-s (scn (compute-gestalt new-s)))) (transition s '()))) ;; Boolean SeqNum -> ConnState -> Transition @@ -422,7 +425,7 @@ (positive? dist))])) (transition new-s (when (and (not (conn-state-syn-acked? s)) (positive? dist)) - (routing-update (compute-gestalt new-s))))))) + (scn (compute-gestalt new-s))))))) ;; Nat -> ConnState -> Transition (define ((update-outbound-window peer-window) s) @@ -474,13 +477,13 @@ (s ,s) (flags ,flags))) (flush-output) - (send (tcp-packet #f dst-ip dst-port src-ip src-port - (buffer-seqn b) - (or ackn 0) - flags - window - #"" - chunk))))) + (message (tcp-packet #f dst-ip dst-port src-ip src-port + (buffer-seqn b) + (or ackn 0) + flags + window + #"" + chunk))))) ;; ConnState -> Transition (define (bump-activity-time s) @@ -490,19 +493,20 @@ ;; ConnState -> Transition (define (quit-when-done s) - (transition s (when (and (buffer-finished? (conn-state-outbound s)) - (buffer-finished? (conn-state-inbound s)) - (all-output-acknowledged? s) - (> (- (current-inexact-milliseconds) - (conn-state-latest-activity-time s)) - (* 2 1000 maximum-segment-lifetime-sec))) - (quit)))) + (if (and (buffer-finished? (conn-state-outbound s)) + (buffer-finished? (conn-state-inbound s)) + (all-output-acknowledged? s) + (> (- (current-inexact-milliseconds) + (conn-state-latest-activity-time s)) + (* 2 1000 maximum-segment-lifetime-sec))) + (quit) + #f)) ;; Action (define send-set-transmit-check-timer - (send (set-timer (timer-name 'transmit-check) - transmit-check-interval-msec - 'relative))) + (message (set-timer (timer-name 'transmit-check) + transmit-check-interval-msec + 'relative))) ;; SeqNum SeqNum ConnState -> Transition (define (reset seqn ackn s) @@ -511,16 +515,13 @@ dst-port (ip-address->hostname src-ip) src-port) - (transition s - (list - (send (tcp-packet #f dst-ip dst-port src-ip src-port - seqn - ackn - (set 'ack 'rst) - 0 - #"" - #"")) - (quit)))) + (quit (message (tcp-packet #f dst-ip dst-port src-ip src-port + seqn + ackn + (set 'ack 'rst) + 0 + #"" + #"")))) ;; ConnState -> Transition (define (close-outbound-stream s) @@ -533,10 +534,12 @@ (define (state-vector-behavior e s) (define old-ackn (buffer-seqn (conn-state-inbound s))) (match e - [(routing-update g) - (log-info "State vector routing-update:\n~a" (gestalt->pretty-string g)) - (define local-peer-present? (not (gestalt-empty? (gestalt-filter g local-peer-detector)))) - (define listening? (not (gestalt-empty? (gestalt-filter g listener-detector)))) + [(scn g) + (log-info "State vector routing-update:\n~a" (trie->pretty-string g)) + (define local-peer-present? + (trie-non-empty? (trie-project g (compile-projection local-peer-detector)))) + (define listening? + (trie-non-empty? (trie-project g (compile-projection listener-detector)))) (define new-s (struct-copy conn-state s [listener-listening? listening?])) (cond [(and local-peer-present? (not (conn-state-local-peer-seen? s))) @@ -548,13 +551,12 @@ bump-activity-time quit-when-done)] [else (transition new-s '())])] - [(message (tcp-packet #t _ _ _ _ seqn ackn flags window options data) _ _) + [(message (tcp-packet #t _ _ _ _ seqn ackn flags window options data)) (define expected (next-expected-seqn s)) (define is-syn? (set-member? flags 'syn)) (define is-fin? (set-member? flags 'fin)) (cond - [(set-member? flags 'rst) - (transition s (quit))] + [(set-member? flags 'rst) (quit)] [(and (not expected) ;; no syn yet (or (not is-syn?) ;; and this isn't it (and (not (conn-state-listener-listening? s)) ;; or it is, but no listener... @@ -578,7 +580,7 @@ (send-outbound old-ackn) bump-activity-time quit-when-done)])] - [(message (tcp-channel _ _ bs) _ _) + [(message (tcp-channel _ _ bs)) ;; (log-info "GOT MORE STUFF TO DELIVER ~v" bs) (sequence-transitions (transition (struct-copy conn-state s [outbound (buffer-push (conn-state-outbound s) bs)]) @@ -586,7 +588,7 @@ (send-outbound old-ackn) bump-activity-time quit-when-done)] - [(message (timer-expired (== (timer-name 'transmit-check)) _) _ _) + [(message (timer-expired (== (timer-name 'transmit-check)) _)) (sequence-transitions (transition s send-set-transmit-check-timer) (send-outbound old-ackn) quit-when-done)] @@ -611,4 +613,4 @@ #f))) (spawn state-vector-behavior state0 - (compute-gestalt state0))))) + (scn (compute-gestalt state0)))))) From 0db231575c4d27cdc3425999d61ac2bd2084ceed Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 24 Jan 2016 00:07:33 -0500 Subject: [PATCH 60/70] Properly assert tcp-port-allocation for a listener. --- tcp.rkt | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index 876c2e7..3f2bca1 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -56,17 +56,18 @@ (lambda (server-addr) (match-define (tcp-listener port) server-addr) ;; TODO: have listener shut down once user-level listener does - (spawn (lambda (e s) #f) - (void) - (assertion (tcp-port-allocation port server-addr))) - (spawn-demand-matcher - (advertise (tcp-channel (?! (tcp-address ? ?)) - (?! (tcp-address ? port)) - ?)) - (observe (tcp-channel (?! (tcp-address ? ?)) - (?! (tcp-address ? port)) - ?)) - (spawn-relay server-addr)))) + (list + (spawn (lambda (e s) #f) + (void) + (scn (assertion (tcp-port-allocation port server-addr)))) + (spawn-demand-matcher + (advertise (tcp-channel (?! (tcp-address ? ?)) + (?! (tcp-address ? port)) + ?)) + (observe (tcp-channel (?! (tcp-address ? ?)) + (?! (tcp-address ? port)) + ?)) + (spawn-relay server-addr))))) (spawn-demand-matcher (advertise (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?)) (observe (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?)) allocate-port-and-spawn-socket) From a86eb10494a1ae9398c81cba99fdf5e82a4868b7 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 27 Jan 2016 21:46:09 -0500 Subject: [PATCH 61/70] Name process behaviour procedures. --- ip.rkt | 3 ++- port-allocator.rkt | 3 ++- tcp.rkt | 28 ++++++++++++++++++++++------ 3 files changed, 26 insertions(+), 8 deletions(-) diff --git a/ip.rkt b/ip.rkt index 7166647..44b3d01 100644 --- a/ip.rkt +++ b/ip.rkt @@ -301,7 +301,8 @@ full-packet) (define (lookup-arp ipaddr query-interface-pattern base-gestalt k) - (on-claim (lambda (_g arp-results) + (on-claim #:name (string->symbol (format "lookup-arp:~a" (ip-address->hostname ipaddr))) + (lambda (_g arp-results) (if (not arp-results) (error 'ip "Someone has published a wildcard arp result") (and (not (set-empty? arp-results)) diff --git a/port-allocator.rkt b/port-allocator.rkt index 533a9e4..e0fe75c 100644 --- a/port-allocator.rkt +++ b/port-allocator.rkt @@ -14,7 +14,8 @@ (struct port-allocator-state (used-ports local-ips) #:transparent) (define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports) - (spawn (lambda (e s) + (spawn #:name (string->symbol (format "port-allocator:~a" allocator-type)) + (lambda (e s) (match e [(scn g) (define local-ips (or (gestalt->local-ip-addresses g) (set))) diff --git a/tcp.rkt b/tcp.rkt index 3f2bca1..1aa461d 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -51,16 +51,20 @@ ;; User-accessible driver startup (define (spawn-tcp-driver) - (list (spawn-demand-matcher (advertise (observe (tcp-channel ? (?! (tcp-listener ?)) ?))) + (list (spawn-demand-matcher #:name 'tcp-inbound-driver + (advertise (observe (tcp-channel ? (?! (tcp-listener ?)) ?))) (advertise (advertise (tcp-channel ? (?! (tcp-listener ?)) ?))) (lambda (server-addr) (match-define (tcp-listener port) server-addr) ;; TODO: have listener shut down once user-level listener does (list - (spawn (lambda (e s) #f) + (spawn #:name (string->symbol + (format "tcp-listener-port-reservation:~a" port)) + (lambda (e s) #f) (void) (scn (assertion (tcp-port-allocation port server-addr)))) (spawn-demand-matcher + #:name (string->symbol (format "tcp-listener:~a" port)) (advertise (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-address ? port)) ?)) @@ -68,7 +72,8 @@ (?! (tcp-address ? port)) ?)) (spawn-relay server-addr))))) - (spawn-demand-matcher (advertise (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?)) + (spawn-demand-matcher #:name 'tcp-outbound-driver + (advertise (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?)) (observe (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?)) allocate-port-and-spawn-socket) (spawn-tcp-port-allocator) @@ -116,7 +121,11 @@ (define remote-peer-traffic (?! (advertise (tcp-channel remote-addr local-tcp-addr ?)))) (list (message (set-timer timer-name relay-peer-wait-time-msec 'relative)) - (spawn (lambda (e state) + (spawn #:name (string->symbol (format "tcp-relay:~v:~v:~v" + local-user-addr + remote-addr + local-tcp-addr)) + (lambda (e state) (match e [(scn g) (define local-peer-absent? @@ -287,7 +296,8 @@ (transition s (message (ip-packet #f src-ip dst-ip PROTOCOL-TCP #"" (ip-checksum 16 payload #:pseudo-header pseudo-header))))) - (spawn (lambda (e s) + (spawn #:name 'kernel-tcp-driver + (lambda (e s) (match e [(scn g) (analyze-gestalt g s)] @@ -612,6 +622,12 @@ (current-inexact-milliseconds) #f #f))) - (spawn state-vector-behavior + (spawn #:name + (string->symbol (format "tcp-state-vector:~a:~a:~a:~a" + (ip-address->hostname src-ip) + src-port + (ip-address->hostname dst-ip) + dst-port)) + state-vector-behavior state0 (scn (compute-gestalt state0)))))) From 38e3c9de0f3713208ca0b71fd58febf4b7770fba Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 27 Jan 2016 21:46:20 -0500 Subject: [PATCH 62/70] Avoid double-fin (!). --- tcp.rkt | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index 1aa461d..d726f31 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -536,10 +536,13 @@ ;; ConnState -> Transition (define (close-outbound-stream s) + (define b (conn-state-outbound s)) (transition - (struct-copy conn-state s - [outbound (struct-copy buffer (buffer-push (conn-state-outbound s) #"!") ;; dummy FIN byte - [finished? #t])]) + (if (buffer-finished? b) + s + (struct-copy conn-state s + [outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte + [finished? #t])])) '())) (define (state-vector-behavior e s) From 6c98531832240817fd22a28e7bcf19a4164e0147 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 27 Jan 2016 21:51:51 -0500 Subject: [PATCH 63/70] Enable "webserver" --- main.rkt | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/main.rkt b/main.rkt index 9d7828c..4ab737c 100644 --- a/main.rkt +++ b/main.rkt @@ -80,10 +80,10 @@ (void) (scn (subscription (udp-packet ? (udp-listener 6667) ?))))) -#;(let () +(let () (define (spawn-session them us) (list - (send 'bump) + (message 'bump) (spawn (lambda (e s) (match e [(message `(counter ,counter)) @@ -97,8 +97,7 @@ "TCP/IP stack.

\n" "

There have been ~a requests prior to this one.

") counter))) - (transition s (list (message #:meta-level 1 (tcp-channel us them response)) - (quit)))] + (quit (message (at-meta (tcp-channel us them response))))] [_ #f])) (void) (scn/union (subscription `(counter ,?)) @@ -106,11 +105,11 @@ (subscription (advertise (tcp-channel them us ?)) #:meta-level 1) (advertisement (tcp-channel us them ?) #:meta-level 1))))) - (spawn-world + (spawn-network (spawn (lambda (e counter) (match e - [(message 'bump _ _) - (transition (+ counter 1) (send `(counter ,counter)))] + [(message 'bump) + (transition (+ counter 1) (message `(counter ,counter)))] [_ #f])) 0 (scn (subscription 'bump))) From 8a3f50941fc7db34a279f6d48380b76e1f165e5e Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 27 Jan 2016 22:06:24 -0500 Subject: [PATCH 64/70] Friendlier makefile contents --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 05a045c..d7ba69b 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,7 @@ all: run: - racketmake main.rkt + raco make main.rkt && racket main.rkt clean: find . -name compiled -type d | xargs rm -rf From 594add5939e42d219c16f64c92211d7a19fecbe0 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 27 Jan 2016 22:06:57 -0500 Subject: [PATCH 65/70] Add in missing bounds check when pruning acked data. --- tcp.rkt | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tcp.rkt b/tcp.rkt index d726f31..c42fd90 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -426,9 +426,11 @@ (if (not ack?) (transition s '()) (let* ((b (conn-state-outbound s)) + (base (buffer-seqn b)) (limit (seq+ (buffer-seqn b) (bit-string-byte-count (buffer-data b)))) (ackn (if (seq> ackn limit) limit ackn)) - (dist (seq- ackn (buffer-seqn b)))) + (ackn (if (seq> base ackn) base ackn)) + (dist (seq- ackn base))) (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset! (define new-s (struct-copy conn-state s [outbound (struct-copy buffer b [data remaining-data] [seqn ackn])] From 265eee348a2b2c28cc83c2ebfcc56481bf93aca2 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 27 Jan 2016 22:15:14 -0500 Subject: [PATCH 66/70] Update fetchurl.rkt for prospect-monolithic. --- fetchurl.rkt | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/fetchurl.rkt b/fetchurl.rkt index 24469b6..a6a62b5 100644 --- a/fetchurl.rkt +++ b/fetchurl.rkt @@ -27,21 +27,23 @@ (spawn (lambda (e seen-peer?) (match e - [(routing-update g) - (define peer-present? (not (gestalt-empty? g))) - (transition (or seen-peer? peer-present?) - (if (and (not peer-present?) seen-peer?) - (quit) - (send (tcp-channel - local-handle - remote-handle - #"GET / HTTP/1.0\r\nHost: stockholm.ccs.neu.edu\r\n\r\n"))))] - [(message (tcp-channel _ _ bs) _ _) + [(scn g) + (define peer-present? (trie-non-empty? g)) + (if (and (not peer-present?) seen-peer?) + (begin (printf "URL fetcher exiting.\n") + (quit)) + (transition (or seen-peer? peer-present?) + (message + (tcp-channel + local-handle + remote-handle + #"GET / HTTP/1.0\r\nHost: stockholm.ccs.neu.edu\r\n\r\n"))))] + [(message (tcp-channel _ _ bs)) (printf "----------------------------------------\n~a\n" bs) (printf "----------------------------------------\n") #f] [_ #f])) #f - (gestalt-union (pub (tcp-channel local-handle remote-handle ?)) - (sub (tcp-channel remote-handle local-handle ?)) - (sub (tcp-channel remote-handle local-handle ?) #:level 1)))) + (scn/union (advertisement (tcp-channel local-handle remote-handle ?)) + (subscription (tcp-channel remote-handle local-handle ?)) + (subscription (advertise (tcp-channel remote-handle local-handle ?)))))) From 3476afc2abbc2a8d756a070f11c7c6dbb7f69c87 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 28 Jan 2016 14:24:05 -0500 Subject: [PATCH 67/70] Implement TCP_USER_TIMEOUT, ish. --- tcp.rkt | 62 +++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 47 insertions(+), 15 deletions(-) diff --git a/tcp.rkt b/tcp.rkt index c42fd90..0df12c5 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -327,7 +327,10 @@ (struct conn-state (outbound ;; buffer inbound ;; buffer syn-acked? ;; boolean - latest-activity-time ;; from current-inexact-milliseconds + latest-peer-activity-time ;; from current-inexact-milliseconds + ;; ^ the most recent time we heard from our peer + user-timeout-base-time ;; from current-inexact-milliseconds + ;; ^ when the index of the first outbound unacknowledged byte changed local-peer-seen? ;; boolean listener-listening?) ;; boolean #:transparent) @@ -336,6 +339,9 @@ (define inbound-buffer-limit 65535) (define maximum-segment-size 536) ;; bytes (define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout +(define user-timeout-msec (* 5 60 1000)) ;; per RFC 793, this should be per-connection, but I + ;; cheat; RFC 793 says "the present global default is five minutes", which is + ;; reasonable to be getting on with (define (spawn-state-vector src-ip src-port dst-ip dst-port) (define src (tcp-address (ip-address->hostname src-ip) src-port)) @@ -433,6 +439,7 @@ (dist (seq- ackn base))) (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset! (define new-s (struct-copy conn-state s + [user-timeout-base-time (current-inexact-milliseconds)] [outbound (struct-copy buffer b [data remaining-data] [seqn ackn])] [syn-acked? (or (conn-state-syn-acked? s) (positive? dist))])) @@ -499,21 +506,38 @@ chunk))))) ;; ConnState -> Transition - (define (bump-activity-time s) + (define (bump-peer-activity-time s) (transition (struct-copy conn-state s - [latest-activity-time (current-inexact-milliseconds)]) + [latest-peer-activity-time (current-inexact-milliseconds)]) '())) + ;; ConnState Number -> Boolean + (define (heard-from-peer-within-msec? s msec) + (<= (- (current-inexact-milliseconds) (conn-state-latest-peer-activity-time s)) msec)) + + ;; ConnState -> Boolean + (define (user-timeout-expired? s) + (and (not (all-output-acknowledged? s)) + (> (- (current-inexact-milliseconds) (conn-state-user-timeout-base-time s)) + user-timeout-msec))) + ;; ConnState -> Transition (define (quit-when-done s) - (if (and (buffer-finished? (conn-state-outbound s)) - (buffer-finished? (conn-state-inbound s)) - (all-output-acknowledged? s) - (> (- (current-inexact-milliseconds) - (conn-state-latest-activity-time s)) - (* 2 1000 maximum-segment-lifetime-sec))) - (quit) - #f)) + (cond + [(and (buffer-finished? (conn-state-outbound s)) + (buffer-finished? (conn-state-inbound s)) + (all-output-acknowledged? s) + (not (heard-from-peer-within-msec? s (* 2 1000 maximum-segment-lifetime-sec)))) + ;; Everything is cleanly shut down, and we just need to wait a while for unexpected + ;; packets before we release the state vector. + (quit)] + [(user-timeout-expired? s) + ;; We've been plaintively retransmitting for user-timeout-msec without hearing anything + ;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but + ;; it will do for now? TODO + (log-info "TCP_USER_TIMEOUT fired.") + (quit)] + [else #f])) ;; Action (define send-set-transmit-check-timer @@ -564,7 +588,6 @@ (log-info "Closing outbound stream.") (sequence-transitions (close-outbound-stream new-s) (send-outbound old-ackn) - bump-activity-time quit-when-done)] [else (transition new-s '())])] [(message (tcp-packet #t _ _ _ _ seqn ackn flags window options data)) @@ -594,17 +617,26 @@ (discard-acknowledged-outbound (set-member? flags 'ack) ackn) (update-outbound-window window) (send-outbound old-ackn) - bump-activity-time + bump-peer-activity-time quit-when-done)])] [(message (tcp-channel _ _ bs)) ;; (log-info "GOT MORE STUFF TO DELIVER ~v" bs) (sequence-transitions (transition (struct-copy conn-state s + [user-timeout-base-time + ;; Only move user-timeout-base-time if there wasn't + ;; already some outstanding output. + (if (all-output-acknowledged? s) + (current-inexact-milliseconds) + (conn-state-user-timeout-base-time s))] [outbound (buffer-push (conn-state-outbound s) bs)]) '()) (send-outbound old-ackn) - bump-activity-time quit-when-done)] [(message (timer-expired (== (timer-name 'transmit-check)) _)) + ;; TODO: I am abusing this timer for multiple tasks. Notably, this is a (crude) means of + ;; retransmitting outbound data as well as a means of checking for an expired + ;; TCP_USER_TIMEOUT. A better design would have separate timers and a more fine-grained + ;; approach. (sequence-transitions (transition s send-set-transmit-check-timer) (send-outbound old-ackn) quit-when-done)] @@ -618,13 +650,13 @@ (inexact->exact (truncate (* #x100000000 (random))))) ;; TODO accept input from user process - ;; TODO append a dummy byte at FIN position in outbound buffer (list send-set-transmit-check-timer (let ((state0 (conn-state (buffer #"!" initial-outbound-seqn 0 #f) ;; dummy data at SYN position (buffer #"" #f inbound-buffer-limit #f) #f (current-inexact-milliseconds) + (current-inexact-milliseconds) #f #f))) (spawn #:name From e400c1703a9bcd397d5d66829f2440ce365ce552 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 28 Jan 2016 15:30:41 -0500 Subject: [PATCH 68/70] stockholm no longer has vboxnet0. --- demo-config.rkt | 1 - 1 file changed, 1 deletion(-) diff --git a/demo-config.rkt b/demo-config.rkt index 1740e58..1fe0ff7 100644 --- a/demo-config.rkt +++ b/demo-config.rkt @@ -20,7 +20,6 @@ (assertion (host-route (bytes 192 168 1 222) 24 "wlan0")))] ["stockholm.ccs.neu.edu" (scn/union (assertion (host-route (bytes 129 10 115 94) 24 "eth0")) - (assertion (host-route (bytes 192 168 56 222) 24 "vboxnet0")) (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))] [else (error 'spawn-demo-config "No setup for hostname ~a" (gethostname))]))) From dd4bd6aae84124ccfbc6be3bc2a3968a9c007f27 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 15 Mar 2016 10:55:50 -0400 Subject: [PATCH 69/70] Update for route.rkt -> trie.rkt switch --- arp.rkt | 10 +++++----- ip.rkt | 18 +++++++++--------- main.rkt | 4 ++-- tcp.rkt | 19 +++++++------------ udp.rkt | 2 +- 5 files changed, 24 insertions(+), 29 deletions(-) diff --git a/arp.rkt b/arp.rkt index fb647b5..50e0bc1 100644 --- a/arp.rkt +++ b/arp.rkt @@ -70,7 +70,7 @@ (assertion (arp-interface-up interface-name)) (subscription (arp-assertion ? ? interface-name)) (subscription (observe (arp-query ? ? interface ?))) - (for/fold [(g (trie-empty))] [((k v) (in-hash cache))] + (for/fold [(g trie-empty)] [((k v) (in-hash cache))] (assertion-set-union g (assertion (arp-query (cache-key-protocol k) (cache-key-address k) (cache-value-interface v) @@ -157,15 +157,15 @@ (compute-gestalt cache))))) (else #f))) - (define queries-projection (compile-projection (observe (arp-query (?!) (?!) ? ?)))) + (define queries-projection (observe (arp-query (?!) (?!) ? ?))) (define (gestalt->queries g) - (for/set [(e (in-set (trie-project/set g queries-projection)))] + (for/set [(e (in-set (trie-project/set #:take 2 g queries-projection)))] (match-define (list ptype pa) e) (cache-key ptype pa))) - (define assertions-projection (compile-projection (arp-assertion (?!) (?!) ?))) + (define assertions-projection (arp-assertion (?!) (?!) ?)) (define (gestalt->assertions g) - (for/set [(e (in-set (trie-project/set g assertions-projection)))] + (for/set [(e (in-set (trie-project/set #:take 2 g assertions-projection)))] (match-define (list ptype pa) e) (cache-key ptype pa))) diff --git a/ip.rkt b/ip.rkt index 44b3d01..fca7183 100644 --- a/ip.rkt +++ b/ip.rkt @@ -53,7 +53,7 @@ (define broadcast-ip-address (bytes 255 255 255 255)) -(define local-ip-address-projector (compile-projection (host-route (?!) ? ?))) +(define local-ip-address-projector (host-route (?!) ? ?)) (define (gestalt->local-ip-addresses g) (trie-project/set/single g local-ip-address-projector)) (define observe-local-ip-addresses-gestalt (subscription (host-route ? ? ?))) @@ -127,9 +127,9 @@ (define (spawn-gateway-route network netmask gateway-addr interface-name) (define the-route (gateway-route network netmask gateway-addr interface-name)) - (define host-route-projector (compile-projection (host-route (?!) (?!) ?))) - (define gateway-route-projector (compile-projection (gateway-route (?!) (?!) ? ?))) - (define net-route-projector (compile-projection (net-route (?!) (?!) ?))) + (define host-route-projector (host-route (?!) (?!) ?)) + (define gateway-route-projector (gateway-route (?!) (?!) ? ?)) + (define net-route-projector (net-route (?!) (?!) ?)) (define gateway-arp-projector (arp-query IPv4-ethertype gateway-addr (?! (ethernet-interface interface-name ?)) @@ -144,11 +144,11 @@ (spawn (lambda (e s) (match e [(scn g) - (define host-ips+netmasks (trie-project/set g host-route-projector)) - (define gw-nets+netmasks (trie-project/set g gateway-route-projector)) - (define net-nets+netmasks (trie-project/set g net-route-projector)) + (define host-ips+netmasks (trie-project/set #:take 2 g host-route-projector)) + (define gw-nets+netmasks (trie-project/set #:take 2 g gateway-route-projector)) + (define net-nets+netmasks (trie-project/set #:take 2 g net-route-projector)) (define gw-ip+hwaddr - (let ((vs (trie-project/set g (compile-projection gateway-arp-projector)))) + (let ((vs (trie-project/set #:take 2 g gateway-arp-projector))) (and vs (not (set-empty? vs)) (set-first vs)))) (when (and gw-ip+hwaddr (not (gateway-route-state-gateway-hwaddr s))) (log-info "Discovered gateway ~a at ~a on interface ~a." @@ -214,7 +214,7 @@ s (lookup-arp destination (ethernet-interface interface-name ?) - (trie-empty) + trie-empty (lambda (interface destination-hwaddr) (message (ethernet-packet interface #f diff --git a/main.rkt b/main.rkt index 4ab737c..0317f2c 100644 --- a/main.rkt +++ b/main.rkt @@ -26,8 +26,8 @@ (define (spawn-session them us) (define user (gensym 'user)) - (define remote-detector (compile-projection (at-meta (?!)))) - (define peer-detector (compile-projection (advertise `(,(?!) says ,?)))) + (define remote-detector (at-meta (?!))) + (define peer-detector (advertise `(,(?!) says ,?))) (define (send-to-remote fmt . vs) (message (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (define (say who fmt . vs) diff --git a/tcp.rkt b/tcp.rkt index 0df12c5..3f3c044 100644 --- a/tcp.rkt +++ b/tcp.rkt @@ -128,10 +128,8 @@ (lambda (e state) (match e [(scn g) - (define local-peer-absent? - (trie-empty? (trie-project g (compile-projection local-peer-traffic)))) - (define remote-peer-absent? - (trie-empty? (trie-project g (compile-projection remote-peer-traffic)))) + (define local-peer-absent? (trie-empty? (trie-project g local-peer-traffic))) + (define remote-peer-absent? (trie-empty? (trie-project g remote-peer-traffic))) (define new-state (+ (if local-peer-absent? 0 1) (if remote-peer-absent? 0 1))) (if (< new-state state) (quit) @@ -234,12 +232,11 @@ (else #f)))) (else #f))) - (define statevec-projection - (compile-projection (observe (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?)))) + (define statevec-projection (observe (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?))) (define (analyze-gestalt g s) (define local-ips (gestalt->local-ip-addresses g)) - (define statevecs (trie-project/set g statevec-projection)) + (define statevecs (trie-project/set #:take 4 g statevec-projection)) (log-info "gestalt yielded statevecs ~v and local-ips ~v" statevecs local-ips) (transition (struct-copy codec-state s [local-ips local-ips] @@ -396,7 +393,7 @@ (if (and (conn-state-syn-acked? s) (not (buffer-finished? (conn-state-inbound s)))) (advertisement (tcp-channel src dst ?)) - (trie-empty)))) + trie-empty))) (assertion-set-union (subscription (timer-expired (timer-name ?) ?)) worldward-facing-gestalt appward-facing-gestalt)) @@ -576,10 +573,8 @@ (match e [(scn g) (log-info "State vector routing-update:\n~a" (trie->pretty-string g)) - (define local-peer-present? - (trie-non-empty? (trie-project g (compile-projection local-peer-detector)))) - (define listening? - (trie-non-empty? (trie-project g (compile-projection listener-detector)))) + (define local-peer-present? (trie-non-empty? (trie-project g local-peer-detector))) + (define listening? (trie-non-empty? (trie-project g listener-detector))) (define new-s (struct-copy conn-state s [listener-listening? listening?])) (cond [(and local-peer-present? (not (conn-state-local-peer-seen? s))) diff --git a/udp.rkt b/udp.rkt index d1302ae..ad3648c 100644 --- a/udp.rkt +++ b/udp.rkt @@ -95,7 +95,7 @@ (match e [(scn g) (define new-local-ips (gestalt->local-ip-addresses g)) - (if (trie-empty? (trie-project g (compile-projection local-peer-detector))) + (if (trie-empty? (trie-project g local-peer-detector)) (quit) (transition new-local-ips (scn (compute-gestalt new-local-ips))))] [(message (udp-packet (== local-user-addr) remote-addr bs)) From 46c35b7d98c38b5ce937a9f7f3f85d4a1deb789b Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Fri, 1 Apr 2016 19:23:33 -0400 Subject: [PATCH 70/70] Move into subfolder in prep for merge --- .gitignore => examples/netstack/.gitignore | 0 Makefile => examples/netstack/Makefile | 0 README.md => examples/netstack/README.md | 0 TODO.md => examples/netstack/TODO.md | 0 arp.rkt => examples/netstack/arp.rkt | 0 checksum.rkt => examples/netstack/checksum.rkt | 0 configuration.rkt => examples/netstack/configuration.rkt | 0 demo-config.rkt => examples/netstack/demo-config.rkt | 0 dump-bytes.rkt => examples/netstack/dump-bytes.rkt | 0 ethernet.rkt => examples/netstack/ethernet.rkt | 0 fetchurl.rkt => examples/netstack/fetchurl.rkt | 0 idle.rkt => examples/netstack/idle.rkt | 0 ip.rkt => examples/netstack/ip.rkt | 0 main.rkt => examples/netstack/main.rkt | 0 port-allocator.rkt => examples/netstack/port-allocator.rkt | 0 tcp.rkt => examples/netstack/tcp.rkt | 0 udp.rkt => examples/netstack/udp.rkt | 0 17 files changed, 0 insertions(+), 0 deletions(-) rename .gitignore => examples/netstack/.gitignore (100%) rename Makefile => examples/netstack/Makefile (100%) rename README.md => examples/netstack/README.md (100%) rename TODO.md => examples/netstack/TODO.md (100%) rename arp.rkt => examples/netstack/arp.rkt (100%) rename checksum.rkt => examples/netstack/checksum.rkt (100%) rename configuration.rkt => examples/netstack/configuration.rkt (100%) rename demo-config.rkt => examples/netstack/demo-config.rkt (100%) rename dump-bytes.rkt => examples/netstack/dump-bytes.rkt (100%) rename ethernet.rkt => examples/netstack/ethernet.rkt (100%) rename fetchurl.rkt => examples/netstack/fetchurl.rkt (100%) rename idle.rkt => examples/netstack/idle.rkt (100%) rename ip.rkt => examples/netstack/ip.rkt (100%) rename main.rkt => examples/netstack/main.rkt (100%) rename port-allocator.rkt => examples/netstack/port-allocator.rkt (100%) rename tcp.rkt => examples/netstack/tcp.rkt (100%) rename udp.rkt => examples/netstack/udp.rkt (100%) diff --git a/.gitignore b/examples/netstack/.gitignore similarity index 100% rename from .gitignore rename to examples/netstack/.gitignore diff --git a/Makefile b/examples/netstack/Makefile similarity index 100% rename from Makefile rename to examples/netstack/Makefile diff --git a/README.md b/examples/netstack/README.md similarity index 100% rename from README.md rename to examples/netstack/README.md diff --git a/TODO.md b/examples/netstack/TODO.md similarity index 100% rename from TODO.md rename to examples/netstack/TODO.md diff --git a/arp.rkt b/examples/netstack/arp.rkt similarity index 100% rename from arp.rkt rename to examples/netstack/arp.rkt diff --git a/checksum.rkt b/examples/netstack/checksum.rkt similarity index 100% rename from checksum.rkt rename to examples/netstack/checksum.rkt diff --git a/configuration.rkt b/examples/netstack/configuration.rkt similarity index 100% rename from configuration.rkt rename to examples/netstack/configuration.rkt diff --git a/demo-config.rkt b/examples/netstack/demo-config.rkt similarity index 100% rename from demo-config.rkt rename to examples/netstack/demo-config.rkt diff --git a/dump-bytes.rkt b/examples/netstack/dump-bytes.rkt similarity index 100% rename from dump-bytes.rkt rename to examples/netstack/dump-bytes.rkt diff --git a/ethernet.rkt b/examples/netstack/ethernet.rkt similarity index 100% rename from ethernet.rkt rename to examples/netstack/ethernet.rkt diff --git a/fetchurl.rkt b/examples/netstack/fetchurl.rkt similarity index 100% rename from fetchurl.rkt rename to examples/netstack/fetchurl.rkt diff --git a/idle.rkt b/examples/netstack/idle.rkt similarity index 100% rename from idle.rkt rename to examples/netstack/idle.rkt diff --git a/ip.rkt b/examples/netstack/ip.rkt similarity index 100% rename from ip.rkt rename to examples/netstack/ip.rkt diff --git a/main.rkt b/examples/netstack/main.rkt similarity index 100% rename from main.rkt rename to examples/netstack/main.rkt diff --git a/port-allocator.rkt b/examples/netstack/port-allocator.rkt similarity index 100% rename from port-allocator.rkt rename to examples/netstack/port-allocator.rkt diff --git a/tcp.rkt b/examples/netstack/tcp.rkt similarity index 100% rename from tcp.rkt rename to examples/netstack/tcp.rkt diff --git a/udp.rkt b/examples/netstack/udp.rkt similarity index 100% rename from udp.rkt rename to examples/netstack/udp.rkt