UDP driver
This commit is contained in:
Tony Garnock-Jones
parent
1fb6935d81
commit
61c59250ee
7
ip.rkt
7
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)
|
||||
|
||||
|
|
|
|||
14
main.rkt
14
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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
77
tcp.rkt
77
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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
Loading…
Reference in New Issue