syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Port netstack to imperative-syndicate. 

If you change `racket-bitsyntax` to use `typed/racket/base/no-check`
for its `bitstring.rkt` module, this runs about 15x faster than the
`syndicate` version of the stack. Otherwise, it runs about 3x faster
than the `syndicate` version of the stack.
This commit is contained in:
Tony Garnock-Jones 2018-05-06 15:09:06 +01:00
parent 35726f3831
commit 43f1eab1f3
15 changed files with 1820 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
syndicate/examples/netstack/Makefile Normal file
View File

@ -0,0 +1,7 @@
all:
run:
raco make main.rkt && racket main.rkt
clean:
find . -name compiled -type d | xargs rm -rf

19
syndicate/examples/netstack/README.md Normal file
View File

@ -0,0 +1,19 @@
# TCP/IP Stack
This implementation is largely the same as the old-Syndicate
"incremental highlevel" implementation, but using new-Syndicate.
## 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

24
syndicate/examples/netstack/TODO.md Normal file
View File

@ -0,0 +1,24 @@
Ideas on TCP unit testing:
<https://www.snellman.net/blog/archive/2015-07-09-unit-testing-a-tcp-stack/>
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
Check that we handle the situations in figs. 9, 10, 11, pp.33- of RFC 793.
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)
Conform better to the rules for reset generation and processing
from pp.36- of RFC 793. In particular, do not blindly accept RSTs
without checking sequence numbers against windows etc.

189
syndicate/examples/netstack/arp.rkt Normal file
View File

@ -0,0 +1,189 @@
#lang imperative-syndicate
;; ARP protocol, http://tools.ietf.org/html/rfc826
;; Only does ARP-over-ethernet.
(provide (struct-out arp-query)
(struct-out arp-assertion)
(struct-out arp-interface))
(require racket/set)
(require racket/match)
(require/activate imperative-syndicate/drivers/timer)
(require bitsyntax)
(require "dump-bytes.rkt")
(require "configuration.rkt")
(require/activate "ethernet.rkt")
(struct arp-query (protocol protocol-address interface-name link-address) #:prefab)
(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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-arp-driver)
(spawn #:name 'arp-driver
(during/spawn (arp-interface $interface-name)
#:name (list 'arp-interface interface-name)
(assert (arp-interface-up interface-name))
(during (ethernet-interface interface-name $hwaddr)
(run-arp-interface interface-name hwaddr)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(struct cache-key (protocol address) #:transparent)
(struct cache-value (expiry interface-name address) #:transparent)
(define (expire-cache c)
(define now (current-inexact-milliseconds))
(define (not-expired? v) (< now (cache-value-expiry v)))
(for/hash [((k v) (in-hash c)) #:when (not-expired? v)]
(values k v)))
(define (run-arp-interface interface-name hwaddr)
(log-info "ARP interface ~v ~v" interface-name hwaddr)
(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
(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 interface-name
#f
hwaddr
dest-mac
ARP-ethertype
packet))
(define (some-asserted-pa ptype)
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (set->list (assertions)))
['() #f]
[(list* k _) (cache-key-address k)]))
(define (send-questions!)
(for [(q (set-subtract (queries) (list->set (hash-keys (cache)))))]
(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))))))
(field [cache (hash)]
[queries (set)]
[assertions (set)])
(field [expiry-deadline (+ (current-inexact-milliseconds) wakeup-interval)])
(on (asserted (later-than (expiry-deadline)))
(cache (expire-cache (cache)))
(send-questions!)
(expiry-deadline (+ (current-inexact-milliseconds) wakeup-interval)))
(on (message ($ p (ethernet-packet-pattern interface-name #t ARP-ethertype)))
(match-define (ethernet-packet _ _ source destination _ body) p)
(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)
(:: 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))
(define sender-hardware-address (bit-string->bytes sender-hardware-address0))
(define target-protocol-address (bit-string->bytes target-protocol-address0))
(define learned-key (cache-key ptype sender-protocol-address))
(when (and (set-member? (queries) learned-key) ;; it is relevant to our interests
(not (equal? sender-hardware-address
(cache-value-address (hash-ref (cache)
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)))
(cache (hash-set (expire-cache (cache))
learned-key
(cache-value (+ (current-inexact-milliseconds)
cache-entry-lifetime-msec)
interface-name
sender-hardware-address)))
(case oper
[(1) ;; request
(when (set-member? (assertions) (cache-key ptype target-protocol-address))
(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) (void)] ;; reply
[else (void)])))
(else #f)))
(during (arp-assertion $protocol $protocol-address interface-name)
(define a (cache-key protocol protocol-address))
(on-start (assertions (set-add (assertions) a))
(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))))
(on-stop (assertions (set-remove (assertions) a))))
(during (observe (arp-query $protocol $protocol-address interface-name _))
(define key (cache-key protocol protocol-address))
(on-start (queries (set-add (queries) key))
(send-questions!))
(on-stop (queries (set-remove (queries) key)))
(assert #:when (hash-has-key? (cache) key)
(match (hash-ref (cache) key)
[(cache-value _ ifname addr)
(arp-query protocol protocol-address ifname addr)]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-arp-driver)

52
syndicate/examples/netstack/checksum.rkt Normal file
View File

@ -0,0 +1,52 @@
#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 #: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 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))
(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))

18
syndicate/examples/netstack/configuration.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang racket/base
(provide (struct-out host-route)
(struct-out gateway-route)
(struct-out net-route)
(struct-out route-up))
;; A Route is one of
;; - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route
;; - (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)
(struct route-up (route) #:prefab) ;; assertion: the given Route is running

21
syndicate/examples/netstack/demo-config.rkt Normal file
View File

@ -0,0 +1,21 @@
#lang imperative-syndicate
;; Demonstration stack configuration for various hosts.
(require racket/match)
(require (only-in mzlib/os gethostname))
(require (only-in racket/string string-split))
(require "configuration.rkt")
(spawn
(match (gethostname)
["stockholm.ccs.neu.edu"
(assert (host-route (bytes 129 10 115 94) 24 "eth0"))
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0"))]
[other ;; assume a private network
(define interface
(match (car (string-split other "."))
["skip" "en0"]
["leap" "wlp4s0"] ;; wtf
[_ "wlan0"]))
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
(assert (host-route (bytes 192 168 1 222) 24 interface))]))

80
syndicate/examples/netstack/dump-bytes.rkt Normal file
View File

@ -0,0 +1,80 @@
#lang racket/base
;; Copyright (C) 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>
;;
;; dump-bytes.rkt is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; dump-bytes.rkt is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with dump-bytes.rkt. If not, see <http://www.gnu.org/licenses/>.
;; Pretty hex dump output of a Bytes.
(provide dump-bytes!
dump-bytes->string
pretty-bytes)
(require (only-in bitsyntax bit-string->bytes))
(require (only-in file/sha1 bytes->hex-string))
(define (pretty-bytes bs)
(bytes->hex-string (bit-string->bytes bs)))
;; Exact Exact -> String
;; Returns the "0"-padded, width-digit hex representation of n
(define (hex width n)
(define s (number->string n 16))
(define slen (string-length s))
(cond
((< slen width) (string-append (make-string (- width slen) #\0) s))
((= slen width) s)
((> slen width) (substring s 0 width))))
;; Bytes Exact -> Void
;; Prints a pretty hex/ASCII dump of bs on (current-output-port).
(define (dump-bytes! bs0 [requested-count #f] #:base [baseaddr 0])
(define bs (bit-string->bytes bs0))
(define count (if requested-count (min requested-count (bytes-length bs)) (bytes-length bs)))
(define clipped (subbytes bs 0 count))
(define (dump-hex i)
(if (< i count)
(display (hex 2 (bytes-ref clipped i)))
(display " "))
(display #\space))
(define (dump-char i)
(if (< i count)
(let ((ch (bytes-ref clipped i)))
(if (<= 32 ch 127)
(display (integer->char ch))
(display #\.)))
(display #\space)))
(define (for-each-between f low high)
(do ((i low (+ i 1)))
((= i high))
(f i)))
(define (dump-line i)
(display (hex 8 (+ i baseaddr)))
(display #\space)
(for-each-between dump-hex i (+ i 8))
(display ": ")
(for-each-between dump-hex (+ i 8) (+ i 16))
(display #\space)
(for-each-between dump-char i (+ i 8))
(display " : ")
(for-each-between dump-char (+ i 8) (+ i 16))
(newline))
(do ((i 0 (+ i 16)))
((>= i count))
(dump-line i)))
(define (dump-bytes->string bs [requested-count #f] #:base [baseaddr 0])
(define s (open-output-string))
(parameterize ((current-output-port s))
(dump-bytes! bs requested-count #:base baseaddr))
(get-output-string s))

120
syndicate/examples/netstack/ethernet.rkt Normal file
View File

@ -0,0 +1,120 @@
#lang imperative-syndicate
;; Ethernet driver
(provide (struct-out available-ethernet-interface)
(struct-out ethernet-interface)
(struct-out ethernet-packet)
zero-ethernet-address
broadcast-ethernet-address
ethernet-packet-pattern)
(require/activate imperative-syndicate/drivers/timer)
(require racket/set)
(require racket/match)
(require racket/async-channel)
(require packet-socket)
(require bitsyntax)
(require "configuration.rkt")
(require "dump-bytes.rkt")
(require imperative-syndicate/pattern-expander)
(assertion-struct available-ethernet-interface (name))
(assertion-struct ethernet-interface (name hwaddr))
(message-struct ethernet-packet (interface-name from-wire? source destination ethertype body))
(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 #:name 'ethernet-driver
(for [(n interface-names)]
(assert (available-ethernet-interface n)))
(during/spawn
(observe (ethernet-packet $interface-name #t _ _ _ _))
#:name (list 'ethernet-interface interface-name)
(define h (raw-interface-open interface-name))
(when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
(log-info "Opened interface ~a, yielding handle ~v" interface-name h)
(assert (ethernet-interface interface-name (raw-interface-hwaddr h)))
(define control-ch (make-async-channel))
(thread (lambda () (interface-packet-read-loop interface-name h control-ch)))
(signal-background-activity! +1)
(on-start (async-channel-put control-ch 'unblock))
(on-stop (async-channel-put control-ch 'quit))
;; (on (message ($ p (ethernet-packet interface #t _ _ _ _)))
;; (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))))
(on (message ($ p (ethernet-packet interface-name #f _ _ _ _)))
;; (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))))))
(define (interface-packet-read-loop interface-name 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-name p))
(when decoded (ground-send! decoded))
(unblocked)]))
(blocked)
(raw-interface-close h)
(signal-background-activity! -1))
(define (decode-ethernet-packet interface-name p)
(bit-string-case p
([ (destination :: binary bytes 6)
(source :: binary bytes 6)
(ethertype :: integer bytes 2)
(body :: binary) ]
(ethernet-packet interface-name
#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))))
(begin-for-declarations
(define-pattern-expander ethernet-packet-pattern
(syntax-rules ()
[(_ interface-name from-wire? ethertype)
(ethernet-packet interface-name from-wire? _ _ ethertype _)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-ethernet-driver)

28
syndicate/examples/netstack/fetchurl.rkt Normal file
View File

@ -0,0 +1,28 @@
#lang imperative-syndicate
(require/activate "ethernet.rkt")
(require/activate "arp.rkt")
(require/activate "ip.rkt")
(require/activate "tcp.rkt")
(require/activate "udp.rkt")
(require/activate "demo-config.rkt")
(require net/dns) ;; not syndicateish yet
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ()
(define host "www.w3.org")
(define connection-id 'httpclient)
(define remote-handle (tcp-address (dns-get-address (dns-find-nameserver) "www.w3.org") 80))
(spawn (assert (tcp-connection connection-id remote-handle))
(on (asserted (tcp-accepted connection-id))
(send! (tcp-out connection-id
(bytes-append #"GET / HTTP/1.0\r\nHost: "
(string->bytes/utf-8 host)
#"\r\n\r\n"))))
(stop-when (retracted (tcp-accepted connection-id))
(printf "URL fetcher exiting.\n"))
(on (message (tcp-in connection-id $bs))
(printf "----------------------------------------\n~a\n" bs)
(printf "----------------------------------------\n"))))

259
syndicate/examples/netstack/ip.rkt Normal file
View File

@ -0,0 +1,259 @@
#lang imperative-syndicate
(provide (struct-out ip-packet)
ip-address->hostname
ip-string->ip-address
apply-netmask
ip-address-in-subnet?
query-local-ip-addresses
broadcast-ip-address
spawn-ip-driver)
(require racket/set)
(require (only-in racket/string string-split))
(require bitsyntax)
(require "dump-bytes.rkt")
(require "configuration.rkt")
(require "checksum.rkt")
(require/activate imperative-syndicate/drivers/timer)
(require/activate "ethernet.rkt")
(require/activate "arp.rkt")
(message-struct ip-packet
(source-interface ;; string for an ethernet interface, or #f for local interfaces
source
destination
protocol
options
body
;; 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 (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) ]
(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 (query-local-ip-addresses)
(query-set local-ips (host-route $addr _ _) addr))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-ip-driver)
(spawn #:name 'ip-driver
(during/spawn (host-route $my-address $netmask $interface-name)
(assert (route-up (host-route my-address netmask interface-name)))
(do-host-route my-address netmask interface-name))
(during/spawn (gateway-route $network $netmask $gateway-addr $interface-name)
(assert (route-up (gateway-route network netmask gateway-addr interface-name)))
(do-gateway-route network netmask gateway-addr interface-name))
(during/spawn (net-route $network-addr $netmask $link)
(assert (route-up (net-route network-addr netmask link)))
(do-net-route network-addr netmask link))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Local IP route
(define (do-host-route my-address netmask interface-name)
(let ((network-addr (apply-netmask my-address netmask)))
(do-normal-ip-route (host-route my-address netmask interface-name)
network-addr
netmask
interface-name))
(assert (arp-assertion IPv4-ethertype my-address interface-name))
(on (message (ip-packet _ $peer-address my-address PROTOCOL-ICMP _ $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)))
(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))]))
(else #f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Gateway IP route
(define (do-gateway-route network netmask gateway-addr interface-name)
(define the-route (gateway-route network netmask gateway-addr interface-name))
(field [routes (set)])
(query-set* routes (host-route $addr $netmask _) (list addr netmask))
(query-set* routes (gateway-route $addr $netmask _ _) (list addr netmask))
(query-set* routes (net-route $addr $netmask _) (list addr netmask))
(define (covered-by-some-other-route? addr)
(for/or ([r (in-set (routes))])
(match-define (list net msk) r)
(and (positive? msk)
(ip-address-in-subnet? addr net msk))))
(during (ethernet-interface interface-name $gateway-interface-hwaddr)
(field [gateway-hwaddr #f])
(on (asserted (arp-query IPv4-ethertype gateway-addr interface-name $hwaddr))
(when (not (gateway-hwaddr))
(log-info "Discovered gateway ~a at ~a on interface ~a."
(ip-address->hostname gateway-addr)
interface-name
(pretty-bytes hwaddr)))
(gateway-hwaddr hwaddr))
(on (message ($ p (ip-packet _ _ _ _ _ _)))
(when (not (gateway-hwaddr))
(log-warning "Gateway hwaddr for ~a not known, packet dropped."
(ip-address->hostname gateway-addr)))
(when (and (gateway-hwaddr)
(not (equal? (ip-packet-source-interface p) interface-name))
(not (covered-by-some-other-route? (ip-packet-destination p))))
(send! (ethernet-packet interface-name
#f
gateway-interface-hwaddr
(gateway-hwaddr)
IPv4-ethertype
(format-ip-packet p)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; General net route
(define (do-net-route network-addr netmask link)
(do-normal-ip-route (net-route network-addr netmask link) network-addr netmask link))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Normal IP route
(define (do-normal-ip-route the-route network netmask interface-name)
(assert (arp-interface interface-name))
(on (message (ethernet-packet interface-name #t _ _ IPv4-ethertype $body))
(define p (parse-ip-packet interface-name body))
(when p (send! p)))
(during (ethernet-interface interface-name $interface-hwaddr)
(on (message ($ p (ip-packet _ _ _ _ _ _)))
(define destination (ip-packet-destination p))
(when (and (not (equal? (ip-packet-source-interface p) interface-name))
(ip-address-in-subnet? destination network netmask))
;; v Use `spawn` instead of `react` to avoid gratuitous packet
;; reordering.
(spawn (stop-when-timeout 5000
(log-warning "ARP lookup of ~a failed, packet dropped"
(ip-address->hostname destination)))
(stop-when (asserted (arp-query IPv4-ethertype
destination
interface-name
$destination-hwaddr))
(send! (ethernet-packet interface-name
#f
interface-hwaddr
destination-hwaddr
IPv4-ethertype
(format-ip-packet p)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define IPv4-ethertype #x0800)
(define IP-VERSION 4)
(define IP-MINIMUM-HEADER-LENGTH 5)
(define PROTOCOL-ICMP 1)
(define default-ttl 64)
(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)))
(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 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)
protocol
(bit-string->bytes opts)
(bit-string->bytes data))))
#f)))
(else #f)))
(define (format-ip-packet p)
(match-define (ip-packet _ src dst protocol options body) p)
(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)
(src :: binary bits 32)
(dst :: binary bits 32)
(options :: binary)))
(define full-packet (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary)))
full-packet)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-ip-driver)

79
syndicate/examples/netstack/main.rkt Normal file
View File

@ -0,0 +1,79 @@
#lang imperative-syndicate
(require/activate imperative-syndicate/drivers/timer)
(require/activate "ethernet.rkt")
(require/activate "arp.rkt")
(require/activate "ip.rkt")
(require/activate "tcp.rkt")
(require/activate "udp.rkt")
(require/activate "demo-config.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ()
(local-require racket/format)
(message-struct speak (who what))
(assertion-struct present (who))
(dataspace #:name 'chat-server-app
(spawn #:name 'chat-server
(during/spawn (inbound (tcp-connection $id (tcp-listener 5999)))
#:name (list 'chat-connection id)
(assert (outbound (tcp-accepted id)))
(let ((me (gensym 'user)))
(assert (present me))
(on (message (inbound (tcp-in-line id $bs)))
(match bs
[#"/quit" (stop-current-facet)]
[_ (send! (speak me (bytes->string/utf-8 bs)))])))
(during (present $user)
(on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n"))))))
(on-stop (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n"))))))
(on (message (speak user $text))
(send! (outbound
(tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n")))))))))))
(let ((dst (udp-listener 6667)))
(dataspace #:name 'udp-echo-program-app
(spawn #:name 'udp-echo-program
(on (message (inbound (udp-packet $src dst $body)))
(log-info "Got packet from ~v: ~v" src body)
(send! (outbound
(udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body)))))))))
(let ()
(dataspace #:name 'webserver-dataspace
(spawn #:name 'webserver-counter
(field [counter 0])
(on (message 'bump)
(send! `(counter ,(counter)))
(counter (+ (counter) 1))))
(define us (tcp-listener 80))
(spawn #:name 'webserver
(during/spawn (inbound (tcp-connection $them us))
#:name (list 'webserver-session them)
(log-info "Got connection from ~v" them)
(assert (outbound (tcp-accepted them)))
(on (message (inbound (tcp-in them _)))) ;; ignore input
(on-start (send! 'bump))
(on (message `(counter ,$counter))
(define response
(string->bytes/utf-8
(format (string-append
"HTTP/1.0 200 OK\r\n"
"Content-Type: text/html\r\n"
"\r\n"
"<h1>Hello world from syndicate-netstack!</h1>\n"
"<p>This is running on syndicate's own\n"
"<a href='https://github.com/tonyg/syndicate/'>\n"
"TCP/IP stack</a>.</p>\n"
"<p>There have been ~a requests prior to this one.</p>\n")
counter)))
(send! (outbound (tcp-out them response)))
(for [(i 4)]
(define buf (make-bytes 1024 (+ #x30 (modulo i 10))))
(send! (outbound (tcp-out them buf))))
(stop-facet (current-facet)))))))

36
syndicate/examples/netstack/port-allocator.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang imperative-syndicate
;; UDP/TCP port allocator
(provide spawn-port-allocator
allocate-port!
(struct-out port-allocation-request)
(struct-out port-allocation-reply))
(require racket/set)
(require "ip.rkt")
(struct port-allocation-request (reqid type) #:prefab)
(struct port-allocation-reply (reqid port) #:prefab)
(define (spawn-port-allocator allocator-type query-used-ports)
(spawn #:name (list 'port-allocator allocator-type)
(define local-ips (query-local-ip-addresses))
(define used-ports (query-used-ports))
(begin/dataflow
(log-info "port-allocator ~v used ports: ~v" allocator-type (used-ports)))
(on (message (port-allocation-request $reqid allocator-type))
(define currently-used-ports (used-ports))
(let randomly-allocate-until-unused ()
(define p (+ 1024 (random 64512)))
(if (set-member? currently-used-ports p)
(randomly-allocate-until-unused)
(begin (used-ports (set-add currently-used-ports p))
(send! (port-allocation-reply reqid p))))))))
(define (allocate-port! type)
(define reqid (gensym 'allocate-port!))
(react/suspend (done)
(stop-when (message (port-allocation-reply reqid $port)) (done port))
(on-start (send! (port-allocation-request reqid type)))))

755
syndicate/examples/netstack/tcp.rkt Normal file
View File

@ -0,0 +1,755 @@
#lang imperative-syndicate
(provide (struct-out tcp-connection)
(struct-out tcp-accepted)
(struct-out tcp-out)
(struct-out tcp-in)
(struct-out tcp-in-line)
(struct-out tcp-address)
(struct-out tcp-listener)
spawn-tcp-driver)
(require racket/set)
(require bitsyntax)
(require "dump-bytes.rkt")
(require "checksum.rkt")
(require/activate imperative-syndicate/drivers/timer)
(require "ip.rkt")
(require "port-allocator.rkt")
(module+ test (require rackunit))
(define-logger netstack/tcp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Protocol messages
(assertion-struct tcp-connection (id spec))
(assertion-struct tcp-accepted (id))
(message-struct tcp-out (id bytes))
(message-struct tcp-in (id bytes))
(message-struct tcp-in-line (id bytes))
(assertion-struct tcp-address (host port))
(assertion-struct tcp-listener (port))
(assertion-struct tcp-quad (remote-ip remote-port local-ip local-port))
(message-struct tcp-packet (from-wire?
quad
sequence-number
ack-number
flags
window-size
options
data))
;; (tcp-port-allocation Number (U TcpAddress TcpListener))
(assertion-struct tcp-port-allocation (port handle))
(define (tcp-quad->string from-wire? q)
(match-define (tcp-quad ri rp li lp) q)
(if from-wire?
(format "(I) ~a:~a -> ~a:~a" (ip-address->hostname ri) rp (ip-address->hostname li) lp)
(format "(O) ~a:~a -> ~a:~a" (ip-address->hostname li) lp (ip-address->hostname ri) rp)))
(define (summarize-tcp-packet packet)
(format "~a (seq ~a, ack ~a, flags ~a, window ~a, payload ~a)"
(tcp-quad->string (tcp-packet-from-wire? packet) (tcp-packet-quad packet))
(tcp-packet-sequence-number packet)
(tcp-packet-ack-number packet)
(tcp-packet-flags packet)
(tcp-packet-window-size packet)
(bit-string-byte-count (tcp-packet-data packet))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Driver startup
(define PROTOCOL-TCP 6)
(define (spawn-tcp-driver)
(spawn-port-allocator 'tcp (lambda () (query-set tcp-ports (tcp-port-allocation $p _) p)))
(spawn #:name 'kernel-tcp-driver
(define local-ips (query-local-ip-addresses))
(define/query-set active-state-vectors ($ q (tcp-quad _ _ _ _)) q)
(define (state-vector-active? statevec)
(set-member? (active-state-vectors) statevec))
(define (analyze-incoming-packet src-ip dst-ip body)
(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 (tcp-quad src-ip src-port dst-ip dst-port))
(old-active-state-vectors (active-state-vectors))
(spawn-needed? (and (not (state-vector-active? statevec))
(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)
(bit-string-case rest
([ (opts :: binary bytes (- (* data-offset 4) 20))
(data :: binary) ]
(let ((packet (tcp-packet #t
statevec
sequence-number
ack-number
flags
window-size
(bit-string->bytes opts)
(bit-string->bytes data))))
(log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet packet))
(when spawn-needed?
(log-netstack/tcp-debug " - spawn needed!")
(active-state-vectors (set-add (active-state-vectors) statevec))
(spawn-state-vector #f (tcp-address (ip-address->hostname src-ip) src-port) statevec))
(send! packet)))
(else #f))))
(else #f)))
(begin/dataflow
(log-netstack/tcp-debug "SCN yielded statevecs ~v and local-ips ~v"
(active-state-vectors)
(local-ips)))
(define (deliver-outbound-packet p)
(match-define (tcp-packet #f
(tcp-quad dst-ip ;; \__ remote
dst-port ;; /
src-ip ;; \__ local
src-port) ;; /
sequence-number
ack-number
flags
window-size
options
data)
p)
(log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet p))
(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)))
(send! (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
(ip-checksum 16 payload #:pseudo-header pseudo-header))))
(on (message (ip-packet $source-if $src $dst PROTOCOL-TCP _ $body))
(when (and source-if ;; source-if == #f iff packet originates locally
(set-member? (local-ips) dst))
(analyze-incoming-packet src dst body)))
(on (message ($ p (tcp-packet #f _ _ _ _ _ _ _)))
(deliver-outbound-packet p))
(during (observe (tcp-connection _ (tcp-listener $port)))
(assert (tcp-port-allocation port (tcp-listener port))))
(on (asserted (tcp-connection $id (tcp-address $remote-host $remote-port)))
(define port (allocate-port! 'tcp))
;; 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 a
;; *wildcard*. 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))
(define remote-ip (ip-string->ip-address remote-host))
(define q (tcp-quad remote-ip remote-port appropriate-ip port))
(active-state-vectors (set-add (active-state-vectors) q))
(spawn-state-vector #t id q))
(during/spawn (observe (tcp-in-line $id _))
#:name (list 'drivers/tcp 'line-reader id)
(local-require (only-in syndicate/support/bytes bytes-index))
(field [buffer #""])
(on (message (tcp-in id $bs)) (buffer (bytes-append (buffer) bs)))
(begin/dataflow
(define newline-pos (bytes-index (buffer) (char->integer #\newline)))
(when newline-pos
(define line (subbytes (buffer) 0 newline-pos))
(buffer (subbytes (buffer) (+ newline-pos 1)))
(send! (tcp-in-line id line)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Per-connection state vector process
;;---------------------------------------------------------------------------
;; From the RFC:
;;
;; Send Sequence Variables
;;
;; SND.UNA - send unacknowledged
;; SND.NXT - send next
;; SND.WND - send window
;; SND.UP - send urgent pointer
;; SND.WL1 - segment sequence number used for last window update
;; SND.WL2 - segment acknowledgment number used for last window
;; update
;; ISS - initial send sequence number
;;
;; Receive Sequence Variables
;;
;; RCV.NXT - receive next
;; RCV.WND - receive window
;; RCV.UP - receive urgent pointer
;; IRS - initial receive sequence number
;;
;; The following diagrams may help to relate some of these variables to
;; the sequence space.
;;
;; Send Sequence Space
;;
;; 1 2 3 4
;; ----------|----------|----------|----------
;; SND.UNA SND.NXT SND.UNA
;; +SND.WND
;;
;; 1 - old sequence numbers which have been acknowledged
;; 2 - sequence numbers of unacknowledged data
;; 3 - sequence numbers allowed for new data transmission
;; 4 - future sequence numbers which are not yet allowed
;;
;; Send Sequence Space
;;
;; Figure 4.
;;
;; The send window is the portion of the sequence space labeled 3 in
;; figure 4.
;;
;; Receive Sequence Space
;;
;; 1 2 3
;; ----------|----------|----------
;; RCV.NXT RCV.NXT
;; +RCV.WND
;;
;; 1 - old sequence numbers which have been acknowledged
;; 2 - sequence numbers allowed for new reception
;; 3 - future sequence numbers which are not yet allowed
;;
;; Receive Sequence Space
;;
;; Figure 5.
;;
;; The receive window is the portion of the sequence space labeled 2 in
;; figure 5.
;;
;; There are also some variables used frequently in the discussion that
;; take their values from the fields of the current segment.
;;
;; Current Segment Variables
;;
;; SEG.SEQ - segment sequence number
;; SEG.ACK - segment acknowledgment number
;; SEG.LEN - segment length
;; SEG.WND - segment window
;; SEG.UP - segment urgent pointer
;; SEG.PRC - segment precedence value
;;
;;---------------------------------------------------------------------------
(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)
;; Regarding acks:
;;
;; - we send an ack number that is (buffer-seqn (inbound)) plus the
;; number of buffered bytes.
;;
;; - acks received allow us to advance (buffer-seqn (outbound)) (that
;; is, SND.UNA) to that point, discarding buffered data to do so.
;; Regarding windows:
;;
;; - (buffer-window (outbound)) is the size of the peer's receive
;; window. Do not allow more than this many bytes to be
;; unacknowledged on the wire.
;;
;; - (buffer-window (inbound)) is the size of our receive window. The
;; peer should not exceed this; we should ignore data received that
;; extends beyond this. Once we implement flow control locally
;; (ahem) we should move this around, but at present it is fixed.
;; TODO: Zero receive window probe when we have something to say.
(define (buffer-push b data)
(struct-copy buffer b [data (bit-string-append (buffer-data b) data)]))
(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 (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)
(not (seq>= b a)))
(define (seq>= a b)
(< (seq- a b) #x80000000))
(define (seq-min a b) (if (seq> a b) b a))
(define (seq-max a b) (if (seq> a b) a b))
(module+ test
(check-equal? (seq+ 41724780 1) 41724781)
(check-equal? (seq+ 0 1) 1)
(check-equal? (seq+ #x80000000 1) #x80000001)
(check-equal? (seq+ #xffffffff 1) #x00000000)
(check-equal? (seq> 41724780 41724780) #f)
(check-equal? (seq> 41724781 41724780) #t)
(check-equal? (seq> 41724780 41724781) #f)
(check-equal? (seq> 0 0) #f)
(check-equal? (seq> 1 0) #t)
(check-equal? (seq> 0 1) #f)
(check-equal? (seq> #x80000000 #x80000000) #f)
(check-equal? (seq> #x80000001 #x80000000) #t)
(check-equal? (seq> #x80000000 #x80000001) #f)
(check-equal? (seq> #xffffffff #xffffffff) #f)
(check-equal? (seq> #x00000000 #xffffffff) #t)
(check-equal? (seq> #xffffffff #x00000000) #f)
(check-equal? (seq>= 41724780 41724780) #t)
(check-equal? (seq>= 41724781 41724780) #t)
(check-equal? (seq>= 41724780 41724781) #f)
(check-equal? (seq>= 0 0) #t)
(check-equal? (seq>= 1 0) #t)
(check-equal? (seq>= 0 1) #f)
(check-equal? (seq>= #x80000000 #x80000000) #t)
(check-equal? (seq>= #x80000001 #x80000000) #t)
(check-equal? (seq>= #x80000000 #x80000001) #f)
(check-equal? (seq>= #xffffffff #xffffffff) #t)
(check-equal? (seq>= #x00000000 #xffffffff) #t)
(check-equal? (seq>= #xffffffff #x00000000) #f))
(define (spawn-state-vector outbound? connection-id q)
(match-define (tcp-quad remote-ip remote-port local-ip local-port) q)
(spawn #:name (list 'tcp-state-vector
(ip-address->hostname remote-ip)
remote-port
(ip-address->hostname local-ip)
local-port)
(define root-facet (current-facet))
(assert (tcp-port-allocation local-port
(tcp-address (ip-address->hostname remote-ip) remote-port)))
(define initial-outbound-seqn
;; Yuck
(inexact->exact (truncate (* #x100000000 (random)))))
(field [outbound (buffer #"!" initial-outbound-seqn 0 #f)] ;; dummy data at SYN position
[send-next initial-outbound-seqn] ;; SND.NXT
[high-water-mark initial-outbound-seqn]
[inbound (buffer #"" #f inbound-buffer-limit #f)]
[transmission-needed? #f]
[syn-acked? #f]
[fin-seen? #f]
[unblocked? #f]
[latest-peer-activity-time (current-inexact-milliseconds)]
;; ^ the most recent time we heard from our peer
[user-timeout-base-time (current-inexact-milliseconds)]
;; ^ when the index of the first outbound unacknowledged byte changed
;; RFC 6298
[rtt-estimate #f] ;; milliseconds; "SRTT"
[rtt-mean-deviation #f] ;; milliseconds; "RTTVAR"
[retransmission-timeout 1000] ;; milliseconds
[retransmission-deadline #f]
[rtt-estimate-seqn-target #f]
[rtt-estimate-start-time #f]
)
(define (next-expected-seqn)
(define b (inbound))
(define v (buffer-seqn b))
(and v (seq+ v (bit-string-byte-count (buffer-data b)))))
(define (set-inbound-seqn! seqn)
(inbound (struct-copy buffer (inbound) [seqn seqn])))
(define (incorporate-segment! data)
(when (not (buffer-finished? (inbound)))
(inbound (buffer-push (inbound) data))))
(define (deliver-inbound-locally!)
(define b (inbound))
(when (not (bit-string-empty? (buffer-data b)))
(define chunk (bit-string->bytes (buffer-data b)))
(send! (tcp-in connection-id chunk))
(inbound (struct-copy buffer b
[data #""]
[seqn (seq+ (buffer-seqn b) (bytes-length chunk))]))))
;; -> Void
(define (check-fin!)
(define b (inbound))
(when (not (buffer-finished? b))
(unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
(error 'check-fin "Nonempty inbound buffer"))
(when (fin-seen?)
(log-netstack/tcp-debug "Closing inbound stream.")
(inbound (struct-copy buffer b
[seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
[finished? #t]))
(transmission-needed? #t)))) ;; we must send an ack
(define (connected?)
(and (syn-acked?) ;; the SYN we sent has been acked by the remote peer
(not (buffer-finished? (inbound))))) ;; the remote peer hasn't sent a FIN
(on (asserted (tcp-accepted connection-id))
(unblocked? #t))
(begin/dataflow
(when (and (connected?) (unblocked?))
(deliver-inbound-locally!)
(check-fin!)))
;; -> Void
(define (arm-retransmission-timer!)
(log-netstack/tcp-debug "Arming retransmission timer (~a ms)" (retransmission-timeout))
(retransmission-deadline (+ (current-inexact-milliseconds) (retransmission-timeout))))
;; Timestamp -> Void
(define (start-rtt-estimate! now)
(define target (send-next))
(when (seq>= target (high-water-mark))
(log-netstack/tcp-debug "Starting RTT estimation; target seqn is ~a" target)
(rtt-estimate-start-time now)
(rtt-estimate-seqn-target target)))
;; -> Void
(define (reset-rtt-estimate!)
(rtt-estimate-start-time #f)
(rtt-estimate-seqn-target #f))
;; Timestamp -> Void
(define (finish-rtt-estimate! now)
(define rtt-measurement (- now (rtt-estimate-start-time)))
(reset-rtt-estimate!)
(log-netstack/tcp-debug "RTT measurement: ~a ms" rtt-measurement)
;; RFC 6298 Section 2.
(cond [(rtt-estimate) => ;; we have a previous estimate, RFC 6298 rule (2.3)
(lambda (prev-estimate)
(rtt-mean-deviation (+ (* 0.75 (rtt-mean-deviation))
(* 0.25 (abs (- rtt-measurement prev-estimate)))))
(rtt-estimate (+ (* 0.875 prev-estimate)
(* 0.125 rtt-measurement))))]
[else ;; no previous estimate, RFC 6298 rule (2.2) applies
(rtt-estimate rtt-measurement)
(rtt-mean-deviation (/ rtt-measurement 2))])
(default-retransmission-timeout!)
(log-netstack/tcp-debug "RTT measurement ~a ms; estimate ~a ms; mean deviation ~a ms; RTO ~a ms"
rtt-measurement
(rtt-estimate)
(rtt-mean-deviation)
(retransmission-timeout)))
(define (default-retransmission-timeout!)
(retransmission-timeout
(max 200 ;; RFC 6298 rule (2.4), but cribbing from Linux's 200ms minimum
(min 60000 ;; (2.5)
(+ (rtt-estimate) (* 4 (rtt-mean-deviation))))))) ;; (2.2), (2.3)
;; Boolean SeqNum -> Void
(define (discard-acknowledged-outbound! ack? ackn)
(when ack?
(let* ((b (outbound))
(base (buffer-seqn b))
(ackn (seq-min ackn (high-water-mark)))
(ackn (seq-max ackn base))
(dist (seq- ackn base)))
(user-timeout-base-time (current-inexact-milliseconds))
(when (positive? dist)
(when (not (syn-acked?)) (syn-acked? #t))
(log-netstack/tcp-debug "******** ackn ~a; send-next ~a; high-water-mark ~a"
ackn
(send-next)
(high-water-mark))
(when (seq> ackn (send-next)) (send-next ackn))
(when (and (rtt-estimate-seqn-target) (seq>= ackn (rtt-estimate-seqn-target)))
(finish-rtt-estimate! (current-inexact-milliseconds)))
(define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
(outbound (struct-copy buffer b [data remaining-data] [seqn ackn]))
(default-retransmission-timeout!)
(log-netstack/tcp-debug "Positive distance moved by ack, RTO now ~a"
(retransmission-timeout))
(arm-retransmission-timer!)))))
;; Nat -> Void
(define (update-outbound-window! peer-window)
(log-netstack/tcp-debug "Peer's receive-window is now ~a" peer-window)
(outbound (struct-copy buffer (outbound) [window peer-window])))
;; True iff there is no queued-up data waiting either for
;; transmission or (if transmitted already) for acknowledgement.
(define (all-output-acknowledged?)
(bit-string-empty? (buffer-data (outbound))))
(define (close-outbound-stream!)
(log-netstack/tcp-debug "Closing outbound stream.")
(define b (outbound))
(when (not (buffer-finished? b))
(outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte
[finished? #t]))
(transmission-needed? #t))) ;; the FIN machinery is awkwardly
;; different from the usual
;; advance-based decision on
;; whether to send a packet or not
;; SeqNum Boolean Boolean Bytes -> TcpPacket
(define (build-outbound-packet seqn mention-syn? mention-fin? payload)
(define ackn (next-expected-seqn))
(define window (min 65535 ;; limit of field width
(max 0 ;; can't be negative
(- (buffer-window (inbound))
(bit-string-byte-count (buffer-data (inbound)))))))
(define flags (set))
(when ackn (set! flags (set-add flags 'ack)))
(when mention-syn? (set! flags (set-add flags 'syn)))
(when mention-fin? (set! flags (set-add flags 'fin)))
(tcp-packet #f q seqn (or ackn 0) flags window #"" payload))
(define (outbound-data-chunk offset length)
(bit-string-take (bit-string-drop (buffer-data (outbound)) (* offset 8)) (* length 8)))
;; Transmit acknowledgements and outbound data.
(begin/dataflow
(define in-flight-count (seq- (send-next) (buffer-seqn (outbound))))
(define-values (mention-syn? ;; whether to mention SYN
payload-size ;; how many bytes of payload data to include
mention-fin? ;; whether to mention FIN
advance) ;; how far to advance send-next
(if (syn-acked?)
(let* ((effective-window (max 0 (- (buffer-window (outbound)) in-flight-count)))
(stream-ended? (buffer-finished? (outbound)))
(max-advance (- (bit-string-byte-count (buffer-data (outbound))) in-flight-count))
(payload-size (min maximum-segment-size effective-window max-advance)))
(if (and stream-ended? ;; there's a FIN enqueued,
(positive? payload-size) ;; we aren't sending nothing at all,
(= payload-size max-advance)) ;; and our payload would cover the FIN
(values #f (- payload-size 1) #t payload-size)
(values #f payload-size #f payload-size)))
(cond [(= in-flight-count 0) (values #t 0 #f 1)]
[(= in-flight-count 1) (values #t 0 #f 0)]
[else (error 'send-outbound!
"Invalid state: send-next had advanced too far before SYN")])))
(when (and (or (next-expected-seqn) outbound?)
;; ^ Talk only either if: we know the peer's seqn, or
;; we don't, but we're an outbound connection rather
;; than a listener.
(or (transmission-needed?)
(positive? advance))
;; ^ ... and we have something to say. Something to
;; ack, or something to send.
)
(define packet-seqn (if mention-syn? (buffer-seqn (outbound)) (send-next)))
(define packet (build-outbound-packet packet-seqn
mention-syn?
mention-fin?
(outbound-data-chunk in-flight-count payload-size)))
(when (positive? advance)
(define new-send-next (seq+ (send-next) advance))
(send-next new-send-next)
(when (seq> new-send-next (high-water-mark))
(high-water-mark new-send-next)))
(when (transmission-needed?)
(transmission-needed? #f))
;; (log-netstack/tcp-debug " sending ~v" packet)
(send! packet)
;; (if (> (random) 0.5)
;; (begin (log-netstack/tcp-debug "Send ~a" (summarize-tcp-packet packet))
;; (send! packet))
;; (log-netstack/tcp-debug "Drop ~a" (summarize-tcp-packet packet)))
(when (or mention-syn? mention-fin? (positive? advance))
(when (not (retransmission-deadline))
(arm-retransmission-timer!))
(when (not (rtt-estimate-start-time))
(start-rtt-estimate! (current-inexact-milliseconds))))))
(begin/dataflow
(when (and (retransmission-deadline) (all-output-acknowledged?))
(log-netstack/tcp-debug "All output acknowledged; disarming retransmission timer")
(retransmission-deadline #f)))
(on #:when (retransmission-deadline) (asserted (later-than (retransmission-deadline)))
(send-next (buffer-seqn (outbound)))
(log-netstack/tcp-debug "Retransmission deadline fired, RTO was ~a; reset to ~a"
(retransmission-timeout)
(send-next))
(update-outbound-window! maximum-segment-size) ;; temporary. Will reopen on next ack
(transmission-needed? #t)
(retransmission-deadline #f)
(reset-rtt-estimate!) ;; give up on current RTT estimation
(retransmission-timeout (min 64000 (* 2 (retransmission-timeout))))
(log-netstack/tcp-debug " RTO now ~a" (retransmission-timeout)))
(define (reset! seqn ackn)
(define reset-packet (tcp-packet #f q seqn ackn (set 'ack 'rst) 0 #"" #""))
(log-netstack/tcp-warning "Reset ~a" (summarize-tcp-packet reset-packet))
(stop-facet root-facet)
(send! reset-packet))
(assert q) ;; Declare that this state vector exists
(on-start (log-netstack/tcp-info "Starting ~a" (tcp-quad->string #t q)))
(on-stop (log-netstack/tcp-info "Stopping ~a" (tcp-quad->string #t q)))
(stop-when #:when (and (buffer-finished? (outbound))
(buffer-finished? (inbound))
(all-output-acknowledged?))
(asserted (later-than (+ (latest-peer-activity-time)
(* 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.
)
(stop-when #:when (not (all-output-acknowledged?))
(asserted (later-than (+ (user-timeout-base-time) user-timeout-msec)))
;; 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-netstack/tcp-warning "TCP_USER_TIMEOUT fired."))
(define/query-value listener-listening?
#f (observe (tcp-connection _ (tcp-listener local-port))) #t)
(define (trigger-ack!)
(transmission-needed? #t))
(on (message (tcp-packet #t q $seqn $ackn $flags $window $options $data))
(define expected (next-expected-seqn))
(define is-syn? (set-member? flags 'syn))
(define is-fin? (set-member? flags 'fin))
(cond
[(set-member? flags 'rst) (stop-facet root-facet)]
[(and (not expected) ;; no syn yet
(or (not is-syn?) ;; and this isn't it
(and (not (listener-listening?)) ;; or it is, but no listener...
(not outbound?)))) ;; ...and we're not an outbound connection
(reset! ackn ;; this is *our* seqn
(seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0)))
;; ^^ this is what we should acknowledge...
)]
[else
(cond
[(not expected) ;; haven't seen syn yet, but we know this is it
(set-inbound-seqn! (seq+ seqn 1))
(incorporate-segment! data)
(trigger-ack!)]
[(= expected seqn)
(incorporate-segment! data)
(when (positive? (bit-string-byte-count data)) (trigger-ack!))]
[else
(trigger-ack!)])
(when is-fin? (fin-seen? #t))
(discard-acknowledged-outbound! (set-member? flags 'ack) ackn)
(update-outbound-window! window)
(latest-peer-activity-time (current-inexact-milliseconds))]))
(on (message (tcp-out connection-id $bs))
;; (log-netstack/tcp-debug "GOT MORE STUFF TO DELIVER ~v" bs)
(when (all-output-acknowledged?)
;; Only move user-timeout-base-time if there wasn't
;; already some outstanding output.
(user-timeout-base-time (current-inexact-milliseconds)))
(outbound (buffer-push (outbound) bs)))
(if outbound?
(begin
(assert #:when (connected?) (tcp-accepted connection-id))
(on (retracted (tcp-connection connection-id (tcp-address _ _)))
(close-outbound-stream!)))
(begin
(assert #:when (connected?) (tcp-connection connection-id (tcp-listener local-port)))
(on (retracted (tcp-accepted connection-id))
(close-outbound-stream!))
(on-start (sleep 5)
(when (not (unblocked?))
(log-netstack/tcp-error "TCP relay process ~a timed out waiting for peer" q)
(stop-facet root-facet)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-tcp-driver)

133
syndicate/examples/netstack/udp.rkt Normal file
View File

@ -0,0 +1,133 @@
#lang imperative-syndicate
(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 bitsyntax)
(require "dump-bytes.rkt")
(require "checksum.rkt")
(require "configuration.rkt")
(require/activate "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)))
;; 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)
(struct udp-port-allocation (port handle) #:prefab) ;; (udp-port-allocation Number UdpLocalAddress)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User-accessible driver startup
(define (spawn-udp-driver)
(spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p)))
(spawn-kernel-udp-driver)
(spawn #:name 'udp-driver
(on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _)))
(spawn-udp-relay (udp-listener-port h) h))
(on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _)))
(spawn #:name (list 'udp-transient h)
(on-start (spawn-udp-relay (allocate-port! 'udp) h))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Relaying
(define (spawn-udp-relay local-port local-user-addr)
(spawn #:name (list 'udp-relay local-port local-user-addr)
(on-start (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr))
(stop-when (retracted (observe (udp-packet _ local-user-addr _))))
(assert (udp-port-allocation local-port local-user-addr))
(during (host-route $ip _ _)
(on (message (udp-datagram $source-ip $source-port ip local-port $bs))
(send!
(udp-packet (udp-remote-address (ip-address->hostname source-ip)
source-port)
local-user-addr
bs))))
(define local-ips (query-local-ip-addresses))
(on (message (udp-packet local-user-addr (udp-remote-address $other-host $other-port) $bs))
;; Choose arbitrary local IP address for outbound packet!
;; TODO: what can be done? Must I examine the routing table?
(send! (udp-datagram (set-first (local-ips))
local-port
(ip-string->ip-address other-host)
other-port
bs)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Codec & kernel-level driver
(define PROTOCOL-UDP 17)
(define (spawn-kernel-udp-driver)
(spawn #:name 'kernel-udp-driver
(define local-ips (query-local-ip-addresses))
(on (message (ip-packet $source-if $src-ip $dst-ip PROTOCOL-UDP _ $body))
(when (and source-if (set-member? (local-ips) 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) ]
(send! (udp-datagram src-ip src-port dst-ip dst-port
(bit-string->bytes payload))))
(else #f)))
(else #f))))
(on (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)))
(send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #""
checksummed-payload)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(spawn-udp-driver)