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