The version of Syndicate current at the conclusion of Tony Garnock-Jones's PhD research, end-of-2017/start-of-2018.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

797 lines
33 KiB

7 years ago
7 years ago
7 years ago
7 years ago
7 years ago
7 years ago
7 years ago
5 years ago
5 years ago
5 years ago
7 years ago
5 years ago
7 years ago
7 years ago
7 years ago
7 years ago
7 years ago
7 years ago
5 years ago
  1. #lang syndicate
  2. (provide (struct-out tcp-address)
  3. (struct-out tcp-handle)
  4. (struct-out tcp-listener)
  5. (struct-out tcp-channel)
  6. spawn-tcp-driver)
  7. (require racket/set)
  8. (require bitsyntax)
  9. (require syndicate/protocol/advertise)
  10. (require "dump-bytes.rkt")
  11. (require "checksum.rkt")
  12. (require/activate syndicate/drivers/timestate)
  13. (require "ip.rkt")
  14. (require "port-allocator.rkt")
  15. (module+ test (require rackunit))
  16. (define-logger netstack/tcp)
  17. ;; tcp-address/tcp-address : "kernel" tcp connection state machines
  18. ;; tcp-handle/tcp-address : "user" outbound connections
  19. ;; tcp-listener/tcp-address : "user" inbound connections
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;; Protocol messages
  22. (struct tcp-address (host port) #:prefab)
  23. (struct tcp-handle (id) #:prefab)
  24. (struct tcp-listener (port) #:prefab)
  25. (struct tcp-channel (source destination subpacket) #:prefab)
  26. (struct tcp-packet (from-wire?
  27. source-ip
  28. source-port
  29. destination-ip
  30. destination-port
  31. sequence-number
  32. ack-number
  33. flags
  34. window-size
  35. options
  36. data)
  37. #:prefab)
  38. ;; (tcp-port-allocation Number (U TcpHandle TcpListener))
  39. (struct tcp-port-allocation (port handle) #:prefab)
  40. (define (summarize-tcp-packet packet)
  41. (format "(~a) ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a, payload ~a)"
  42. (if (tcp-packet-from-wire? packet) "I" "O")
  43. (ip-address->hostname (tcp-packet-source-ip packet))
  44. (tcp-packet-source-port packet)
  45. (ip-address->hostname (tcp-packet-destination-ip packet))
  46. (tcp-packet-destination-port packet)
  47. (tcp-packet-sequence-number packet)
  48. (tcp-packet-ack-number packet)
  49. (tcp-packet-flags packet)
  50. (tcp-packet-window-size packet)
  51. (bit-string-byte-count (tcp-packet-data packet))))
  52. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53. ;; User-accessible driver startup
  54. (define (spawn-tcp-driver)
  55. (spawn-port-allocator 'tcp (lambda () (query-set tcp-ports (tcp-port-allocation $p _) p)))
  56. (spawn-kernel-tcp-driver)
  57. (spawn #:name 'tcp-inbound-driver
  58. (during/spawn (advertise (observe (tcp-channel _ ($ server-addr (tcp-listener _)) _)))
  59. #:name (list 'tcp-listen server-addr)
  60. (match-define (tcp-listener port) server-addr)
  61. (assert (tcp-port-allocation port server-addr))
  62. (on (asserted (advertise (tcp-channel ($ remote-addr (tcp-address _ _))
  63. ($ local-addr (tcp-address _ port))
  64. _)))
  65. (spawn-relay server-addr remote-addr local-addr))))
  66. (spawn #:name 'tcp-outbound-driver
  67. (define local-ips (query-local-ip-addresses))
  68. (on (asserted (advertise (tcp-channel ($ local-addr (tcp-handle _))
  69. ($ remote-addr (tcp-address _ _))
  70. _)))
  71. (define port (allocate-port! 'tcp))
  72. ;; TODO: Choose a sensible IP address for the outbound
  73. ;; connection. We don't have enough information to do this
  74. ;; well at the moment, so just pick some available local IP
  75. ;; address.
  76. ;;
  77. ;; Interesting note: In some sense, the right answer is
  78. ;; "?". This would give us a form of mobility, where IP
  79. ;; addresses only route to a given bucket-of-state and ONLY
  80. ;; the port number selects a substate therein. That's not
  81. ;; how TCP is defined however so we can't do that.
  82. (define appropriate-ip (set-first (local-ips)))
  83. (define appropriate-host (ip-address->hostname appropriate-ip))
  84. (match-define (tcp-address remote-host remote-port) remote-addr)
  85. (define remote-ip (ip-string->ip-address remote-host))
  86. (spawn-relay local-addr remote-addr (tcp-address appropriate-host port))
  87. (spawn-state-vector remote-ip remote-port appropriate-ip port))))
  88. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89. ;; Relay between kernel-level and user-level
  90. (define relay-peer-wait-time-msec 5000)
  91. (define (spawn-relay local-user-addr remote-addr local-tcp-addr)
  92. (define timer-name (list 'spawn-relay local-tcp-addr remote-addr))
  93. (spawn #:name (list 'tcp-relay local-user-addr remote-addr local-tcp-addr)
  94. (assert (tcp-port-allocation (tcp-address-port local-tcp-addr) local-user-addr))
  95. (assert (advertise (tcp-channel remote-addr local-user-addr _)))
  96. (assert (advertise (tcp-channel local-tcp-addr remote-addr _)))
  97. (field [local-peer-present? #f]
  98. [remote-peer-present? #f])
  99. (on-timeout relay-peer-wait-time-msec
  100. (when (not (and (local-peer-present?) (remote-peer-present?)))
  101. (error 'spawn-relay "TCP relay process timed out waiting for peer")))
  102. (on (asserted (observe (tcp-channel remote-addr local-user-addr _)))
  103. (local-peer-present? #t))
  104. (stop-when (retracted (observe (tcp-channel remote-addr local-user-addr _))))
  105. (on (asserted (advertise (tcp-channel remote-addr local-tcp-addr _)))
  106. (remote-peer-present? #t))
  107. (stop-when (retracted (advertise (tcp-channel remote-addr local-tcp-addr _))))
  108. (on (message (tcp-channel local-user-addr remote-addr $bs))
  109. (send! (tcp-channel local-tcp-addr remote-addr bs)))
  110. (on (message (tcp-channel remote-addr local-tcp-addr $bs))
  111. (send! (tcp-channel remote-addr local-user-addr bs)))))
  112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  113. ;; Codec & kernel-level driver
  114. (define PROTOCOL-TCP 6)
  115. (define (spawn-kernel-tcp-driver)
  116. (spawn #:name 'kernel-tcp-driver
  117. (define local-ips (query-local-ip-addresses))
  118. (define active-state-vectors
  119. (query-set active-state-vectors
  120. (observe (tcp-packet #t $si $sp $di $dp _ _ _ _ _ _))
  121. (list si sp di dp)))
  122. (define (state-vector-active? statevec)
  123. (set-member? (active-state-vectors) statevec))
  124. (define (analyze-incoming-packet src-ip dst-ip body)
  125. (bit-string-case body
  126. ([ (src-port :: integer bytes 2)
  127. (dst-port :: integer bytes 2)
  128. (sequence-number :: integer bytes 4)
  129. (ack-number :: integer bytes 4)
  130. (data-offset :: integer bits 4)
  131. (reserved :: integer bits 3)
  132. (ns :: integer bits 1)
  133. (cwr :: integer bits 1)
  134. (ece :: integer bits 1)
  135. (urg :: integer bits 1)
  136. (ack :: integer bits 1)
  137. (psh :: integer bits 1)
  138. (rst :: integer bits 1)
  139. (syn :: integer bits 1)
  140. (fin :: integer bits 1)
  141. (window-size :: integer bytes 2)
  142. (checksum :: integer bytes 2) ;; TODO: check checksum
  143. (urgent-pointer :: integer bytes 2)
  144. (rest :: binary) ]
  145. (let* ((flags (set))
  146. (statevec (list src-ip src-port dst-ip dst-port))
  147. (old-active-state-vectors (active-state-vectors))
  148. (spawn-needed? (and (not (state-vector-active? statevec))
  149. (zero? rst)))) ;; don't bother spawning if it's a rst
  150. (define-syntax-rule (set-flags! v ...)
  151. (begin (unless (zero? v) (set! flags (set-add flags 'v))) ...))
  152. (set-flags! ns cwr ece urg ack psh rst syn fin)
  153. (bit-string-case rest
  154. ([ (opts :: binary bytes (- (* data-offset 4) 20))
  155. (data :: binary) ]
  156. (let ((packet (tcp-packet #t
  157. src-ip
  158. src-port
  159. dst-ip
  160. dst-port
  161. sequence-number
  162. ack-number
  163. flags
  164. window-size
  165. (bit-string->bytes opts)
  166. (bit-string->bytes data))))
  167. (log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet packet))
  168. (when spawn-needed?
  169. (log-netstack/tcp-debug " - spawn needed!")
  170. (active-state-vectors (set-add (active-state-vectors) statevec))
  171. (spawn-state-vector src-ip src-port dst-ip dst-port))
  172. (send! packet)))
  173. (else #f))))
  174. (else #f)))
  175. (begin/dataflow
  176. (log-netstack/tcp-debug "SCN yielded statevecs ~v and local-ips ~v"
  177. (active-state-vectors)
  178. (local-ips)))
  179. (define (deliver-outbound-packet p)
  180. (match-define (tcp-packet #f
  181. src-ip
  182. src-port
  183. dst-ip
  184. dst-port
  185. sequence-number
  186. ack-number
  187. flags
  188. window-size
  189. options
  190. data)
  191. p)
  192. (log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet p))
  193. (define (flag-bit sym) (if (set-member? flags sym) 1 0))
  194. (define payload (bit-string (src-port :: integer bytes 2)
  195. (dst-port :: integer bytes 2)
  196. (sequence-number :: integer bytes 4)
  197. (ack-number :: integer bytes 4)
  198. ((+ 5 (quotient (bit-string-byte-count options) 4))
  199. :: integer bits 4) ;; TODO: enforce 4-byte alignment
  200. (0 :: integer bits 3)
  201. ((flag-bit 'ns) :: integer bits 1)
  202. ((flag-bit 'cwr) :: integer bits 1)
  203. ((flag-bit 'ece) :: integer bits 1)
  204. ((flag-bit 'urg) :: integer bits 1)
  205. ((flag-bit 'ack) :: integer bits 1)
  206. ((flag-bit 'psh) :: integer bits 1)
  207. ((flag-bit 'rst) :: integer bits 1)
  208. ((flag-bit 'syn) :: integer bits 1)
  209. ((flag-bit 'fin) :: integer bits 1)
  210. (window-size :: integer bytes 2)
  211. (0 :: integer bytes 2) ;; checksum location
  212. (0 :: integer bytes 2) ;; TODO: urgent pointer
  213. (data :: binary)))
  214. (define pseudo-header (bit-string (src-ip :: binary bytes 4)
  215. (dst-ip :: binary bytes 4)
  216. 0
  217. PROTOCOL-TCP
  218. ((bit-string-byte-count payload) :: integer bytes 2)))
  219. (send! (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
  220. (ip-checksum 16 payload #:pseudo-header pseudo-header))))
  221. (on (message (ip-packet $source-if $src $dst PROTOCOL-TCP _ $body))
  222. (when (and source-if ;; source-if == #f iff packet originates locally
  223. (set-member? (local-ips) dst))
  224. (analyze-incoming-packet src dst body)))
  225. (on (message ($ p (tcp-packet #f _ _ _ _ _ _ _ _ _ _)))
  226. (deliver-outbound-packet p))))
  227. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  228. ;; Per-connection state vector process
  229. ;;---------------------------------------------------------------------------
  230. ;; From the RFC:
  231. ;;
  232. ;; Send Sequence Variables
  233. ;;
  234. ;; SND.UNA - send unacknowledged
  235. ;; SND.NXT - send next
  236. ;; SND.WND - send window
  237. ;; SND.UP - send urgent pointer
  238. ;; SND.WL1 - segment sequence number used for last window update
  239. ;; SND.WL2 - segment acknowledgment number used for last window
  240. ;; update
  241. ;; ISS - initial send sequence number
  242. ;;
  243. ;; Receive Sequence Variables
  244. ;;
  245. ;; RCV.NXT - receive next
  246. ;; RCV.WND - receive window
  247. ;; RCV.UP - receive urgent pointer
  248. ;; IRS - initial receive sequence number
  249. ;;
  250. ;; The following diagrams may help to relate some of these variables to
  251. ;; the sequence space.
  252. ;;
  253. ;; Send Sequence Space
  254. ;;
  255. ;; 1 2 3 4
  256. ;; ----------|----------|----------|----------
  257. ;; SND.UNA SND.NXT SND.UNA
  258. ;; +SND.WND
  259. ;;
  260. ;; 1 - old sequence numbers which have been acknowledged
  261. ;; 2 - sequence numbers of unacknowledged data
  262. ;; 3 - sequence numbers allowed for new data transmission
  263. ;; 4 - future sequence numbers which are not yet allowed
  264. ;;
  265. ;; Send Sequence Space
  266. ;;
  267. ;; Figure 4.
  268. ;;
  269. ;; The send window is the portion of the sequence space labeled 3 in
  270. ;; figure 4.
  271. ;;
  272. ;; Receive Sequence Space
  273. ;;
  274. ;; 1 2 3
  275. ;; ----------|----------|----------
  276. ;; RCV.NXT RCV.NXT
  277. ;; +RCV.WND
  278. ;;
  279. ;; 1 - old sequence numbers which have been acknowledged
  280. ;; 2 - sequence numbers allowed for new reception
  281. ;; 3 - future sequence numbers which are not yet allowed
  282. ;;
  283. ;; Receive Sequence Space
  284. ;;
  285. ;; Figure 5.
  286. ;;
  287. ;; The receive window is the portion of the sequence space labeled 2 in
  288. ;; figure 5.
  289. ;;
  290. ;; There are also some variables used frequently in the discussion that
  291. ;; take their values from the fields of the current segment.
  292. ;;
  293. ;; Current Segment Variables
  294. ;;
  295. ;; SEG.SEQ - segment sequence number
  296. ;; SEG.ACK - segment acknowledgment number
  297. ;; SEG.LEN - segment length
  298. ;; SEG.WND - segment window
  299. ;; SEG.UP - segment urgent pointer
  300. ;; SEG.PRC - segment precedence value
  301. ;;
  302. ;;---------------------------------------------------------------------------
  303. (struct buffer (data ;; bit-string
  304. seqn ;; names leftmost byte in data
  305. window ;; counts bytes from leftmost byte in data
  306. finished?) ;; boolean: true after FIN
  307. #:transparent)
  308. ;; Regarding acks:
  309. ;;
  310. ;; - we send an ack number that is (buffer-seqn (inbound)) plus the
  311. ;; number of buffered bytes.
  312. ;;
  313. ;; - acks received allow us to advance (buffer-seqn (outbound)) (that
  314. ;; is, SND.UNA) to that point, discarding buffered data to do so.
  315. ;; Regarding windows:
  316. ;;
  317. ;; - (buffer-window (outbound)) is the size of the peer's receive
  318. ;; window. Do not allow more than this many bytes to be
  319. ;; unacknowledged on the wire.
  320. ;;
  321. ;; - (buffer-window (inbound)) is the size of our receive window. The
  322. ;; peer should not exceed this; we should ignore data received that
  323. ;; extends beyond this. Once we implement flow control locally
  324. ;; (ahem) we should move this around, but at present it is fixed.
  325. ;; TODO: Zero receive window probe when we have something to say.
  326. (define (buffer-push b data)
  327. (struct-copy buffer b [data (bit-string-append (buffer-data b) data)]))
  328. (define inbound-buffer-limit 65535)
  329. (define maximum-segment-size 536) ;; bytes
  330. (define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout
  331. (define user-timeout-msec (* 5 60 1000)) ;; per RFC 793, this should be per-connection, but I
  332. ;; cheat; RFC 793 says "the present global default is five minutes", which is
  333. ;; reasonable to be getting on with
  334. (define (seq+ a b) (bitwise-and #xffffffff (+ a b)))
  335. ;; Always positive
  336. (define (seq- larger smaller)
  337. (if (< larger smaller) ;; wraparound has occurred
  338. (+ (- larger smaller) #x100000000)
  339. (- larger smaller)))
  340. (define (seq> a b)
  341. (not (seq>= b a)))
  342. (define (seq>= a b)
  343. (< (seq- a b) #x80000000))
  344. (define (seq-min a b) (if (seq> a b) b a))
  345. (define (seq-max a b) (if (seq> a b) a b))
  346. (module+ test
  347. (check-equal? (seq+ 41724780 1) 41724781)
  348. (check-equal? (seq+ 0 1) 1)
  349. (check-equal? (seq+ #x80000000 1) #x80000001)
  350. (check-equal? (seq+ #xffffffff 1) #x00000000)
  351. (check-equal? (seq> 41724780 41724780) #f)
  352. (check-equal? (seq> 41724781 41724780) #t)
  353. (check-equal? (seq> 41724780 41724781) #f)
  354. (check-equal? (seq> 0 0) #f)
  355. (check-equal? (seq> 1 0) #t)
  356. (check-equal? (seq> 0 1) #f)
  357. (check-equal? (seq> #x80000000 #x80000000) #f)
  358. (check-equal? (seq> #x80000001 #x80000000) #t)
  359. (check-equal? (seq> #x80000000 #x80000001) #f)
  360. (check-equal? (seq> #xffffffff #xffffffff) #f)
  361. (check-equal? (seq> #x00000000 #xffffffff) #t)
  362. (check-equal? (seq> #xffffffff #x00000000) #f)
  363. (check-equal? (seq>= 41724780 41724780) #t)
  364. (check-equal? (seq>= 41724781 41724780) #t)
  365. (check-equal? (seq>= 41724780 41724781) #f)
  366. (check-equal? (seq>= 0 0) #t)
  367. (check-equal? (seq>= 1 0) #t)
  368. (check-equal? (seq>= 0 1) #f)
  369. (check-equal? (seq>= #x80000000 #x80000000) #t)
  370. (check-equal? (seq>= #x80000001 #x80000000) #t)
  371. (check-equal? (seq>= #x80000000 #x80000001) #f)
  372. (check-equal? (seq>= #xffffffff #xffffffff) #t)
  373. (check-equal? (seq>= #x00000000 #xffffffff) #t)
  374. (check-equal? (seq>= #xffffffff #x00000000) #f))
  375. (define (spawn-state-vector src-ip src-port dst-ip dst-port)
  376. (define src (tcp-address (ip-address->hostname src-ip) src-port))
  377. (define dst (tcp-address (ip-address->hostname dst-ip) dst-port))
  378. (spawn
  379. #:name (list 'tcp-state-vector
  380. (ip-address->hostname src-ip)
  381. src-port
  382. (ip-address->hostname dst-ip)
  383. dst-port)
  384. ;; Spawn with initial assertions so we are guaranteed to be sent
  385. ;; the packet that led to our creation (in the case of an accepted
  386. ;; server connection), and so that we at the same moment gain
  387. ;; knowledge of whether we were created on a listening port:
  388. #:assertions* (patch-added
  389. (patch-seq (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?))
  390. (sub (observe (advertise (tcp-channel ? (tcp-listener dst-port) ?))))))
  391. (define root-facet (current-facet-id))
  392. (define initial-outbound-seqn
  393. ;; Yuck
  394. (inexact->exact (truncate (* #x100000000 (random)))))
  395. (field [outbound (buffer #"!" initial-outbound-seqn 0 #f)] ;; dummy data at SYN position
  396. [send-next initial-outbound-seqn] ;; SND.NXT
  397. [high-water-mark initial-outbound-seqn]
  398. [inbound (buffer #"" #f inbound-buffer-limit #f)]
  399. [transmission-needed? #f]
  400. [syn-acked? #f]
  401. [latest-peer-activity-time (current-inexact-milliseconds)]
  402. ;; ^ the most recent time we heard from our peer
  403. [user-timeout-base-time (current-inexact-milliseconds)]
  404. ;; ^ when the index of the first outbound unacknowledged byte changed
  405. ;; RFC 6298
  406. [rtt-estimate #f] ;; milliseconds; "SRTT"
  407. [rtt-mean-deviation #f] ;; milliseconds; "RTTVAR"
  408. [retransmission-timeout 1000] ;; milliseconds
  409. [retransmission-deadline #f]
  410. [rtt-estimate-seqn-target #f]
  411. [rtt-estimate-start-time #f]
  412. )
  413. (define (next-expected-seqn)
  414. (define b (inbound))
  415. (define v (buffer-seqn b))
  416. (and v (seq+ v (bit-string-byte-count (buffer-data b)))))
  417. (define (set-inbound-seqn! seqn)
  418. (inbound (struct-copy buffer (inbound) [seqn seqn])))
  419. (define (incorporate-segment! data)
  420. (when (not (buffer-finished? (inbound)))
  421. (inbound (buffer-push (inbound) data))))
  422. (define (deliver-inbound-locally!)
  423. (define b (inbound))
  424. (when (not (bit-string-empty? (buffer-data b)))
  425. (define chunk (bit-string->bytes (buffer-data b)))
  426. (send! (tcp-channel src dst chunk))
  427. (inbound (struct-copy buffer b
  428. [data #""]
  429. [seqn (seq+ (buffer-seqn b) (bytes-length chunk))]))))
  430. ;; (Setof Symbol) -> Void
  431. (define (check-fin! flags)
  432. (define b (inbound))
  433. (when (not (buffer-finished? b))
  434. (unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
  435. (error 'check-fin "Nonempty inbound buffer"))
  436. (when (set-member? flags 'fin)
  437. (log-netstack/tcp-debug "Closing inbound stream.")
  438. (inbound (struct-copy buffer b
  439. [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
  440. [finished? #t]))
  441. (transmission-needed? #t)))) ;; we must send an ack
  442. ;; -> Void
  443. (define (arm-retransmission-timer!)
  444. (log-netstack/tcp-debug "Arming retransmission timer (~a ms)" (retransmission-timeout))
  445. (retransmission-deadline (+ (current-inexact-milliseconds) (retransmission-timeout))))
  446. ;; Timestamp -> Void
  447. (define (start-rtt-estimate! now)
  448. (define target (send-next))
  449. (when (seq>= target (high-water-mark))
  450. (log-netstack/tcp-debug "Starting RTT estimation; target seqn is ~a" target)
  451. (rtt-estimate-start-time now)
  452. (rtt-estimate-seqn-target target)))
  453. ;; -> Void
  454. (define (reset-rtt-estimate!)
  455. (rtt-estimate-start-time #f)
  456. (rtt-estimate-seqn-target #f))
  457. ;; Timestamp -> Void
  458. (define (finish-rtt-estimate! now)
  459. (define rtt-measurement (- now (rtt-estimate-start-time)))
  460. (reset-rtt-estimate!)
  461. (log-netstack/tcp-debug "RTT measurement: ~a ms" rtt-measurement)
  462. ;; RFC 6298 Section 2.
  463. (cond [(rtt-estimate) => ;; we have a previous estimate, RFC 6298 rule (2.3)
  464. (lambda (prev-estimate)
  465. (rtt-mean-deviation (+ (* 0.75 (rtt-mean-deviation))
  466. (* 0.25 (abs (- rtt-measurement prev-estimate)))))
  467. (rtt-estimate (+ (* 0.875 prev-estimate)
  468. (* 0.125 rtt-measurement))))]
  469. [else ;; no previous estimate, RFC 6298 rule (2.2) applies
  470. (rtt-estimate rtt-measurement)
  471. (rtt-mean-deviation (/ rtt-measurement 2))])
  472. (default-retransmission-timeout!)
  473. (log-netstack/tcp-debug "RTT measurement ~a ms; estimate ~a ms; mean deviation ~a ms; RTO ~a ms"
  474. rtt-measurement
  475. (rtt-estimate)
  476. (rtt-mean-deviation)
  477. (retransmission-timeout)))
  478. (define (default-retransmission-timeout!)
  479. (retransmission-timeout
  480. (max 200 ;; RFC 6298 rule (2.4), but cribbing from Linux's 200ms minimum
  481. (min 60000 ;; (2.5)
  482. (+ (rtt-estimate) (* 4 (rtt-mean-deviation))))))) ;; (2.2), (2.3)
  483. ;; Boolean SeqNum -> Void
  484. (define (discard-acknowledged-outbound! ack? ackn)
  485. (when ack?
  486. (let* ((b (outbound))
  487. (base (buffer-seqn b))
  488. (ackn (seq-min ackn (high-water-mark)))
  489. (ackn (seq-max ackn base))
  490. (dist (seq- ackn base)))
  491. (user-timeout-base-time (current-inexact-milliseconds))
  492. (when (positive? dist)
  493. (when (not (syn-acked?)) (syn-acked? #t))
  494. (log-netstack/tcp-debug "******** ackn ~a; send-next ~a; high-water-mark ~a"
  495. ackn
  496. (send-next)
  497. (high-water-mark))
  498. (when (seq> ackn (send-next)) (send-next ackn))
  499. (when (and (rtt-estimate-seqn-target) (seq>= ackn (rtt-estimate-seqn-target)))
  500. (finish-rtt-estimate! (current-inexact-milliseconds)))
  501. (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
  502. (outbound (struct-copy buffer b [data remaining-data] [seqn ackn]))
  503. (default-retransmission-timeout!)
  504. (log-netstack/tcp-debug "Positive distance moved by ack, RTO now ~a"
  505. (retransmission-timeout))
  506. (arm-retransmission-timer!)))))
  507. ;; Nat -> Void
  508. (define (update-outbound-window! peer-window)
  509. (log-netstack/tcp-debug "Peer's receive-window is now ~a" peer-window)
  510. (outbound (struct-copy buffer (outbound) [window peer-window])))
  511. ;; True iff there is no queued-up data waiting either for
  512. ;; transmission or (if transmitted already) for acknowledgement.
  513. (define (all-output-acknowledged?)
  514. (bit-string-empty? (buffer-data (outbound))))
  515. (define (close-outbound-stream!)
  516. (define b (outbound))
  517. (when (not (buffer-finished? b))
  518. (outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte
  519. [finished? #t]))
  520. (transmission-needed? #t))) ;; the FIN machinery is awkwardly
  521. ;; different from the usual
  522. ;; advance-based decision on
  523. ;; whether to send a packet or not
  524. ;; SeqNum Boolean Boolean Bytes -> TcpPacket
  525. (define (build-outbound-packet seqn mention-syn? mention-fin? payload)
  526. (define ackn (next-expected-seqn))
  527. (define window (min 65535 ;; limit of field width
  528. (max 0 ;; can't be negative
  529. (- (buffer-window (inbound))
  530. (bit-string-byte-count (buffer-data (inbound)))))))
  531. (define flags (set))
  532. (when ackn (set! flags (set-add flags 'ack)))
  533. (when mention-syn? (set! flags (set-add flags 'syn)))
  534. (when mention-fin? (set! flags (set-add flags 'fin)))
  535. (tcp-packet #f dst-ip dst-port src-ip src-port
  536. seqn
  537. (or ackn 0)
  538. flags
  539. window
  540. #""
  541. payload))
  542. (define (outbound-data-chunk offset length)
  543. (bit-string-take (bit-string-drop (buffer-data (outbound)) (* offset 8)) (* length 8)))
  544. ;; Transmit acknowledgements and outbound data.
  545. (begin/dataflow
  546. (define in-flight-count (seq- (send-next) (buffer-seqn (outbound))))
  547. (define-values (mention-syn? ;; whether to mention SYN
  548. payload-size ;; how many bytes of payload data to include
  549. mention-fin? ;; whether to mention FIN
  550. advance) ;; how far to advance send-next
  551. (if (syn-acked?)
  552. (let* ((effective-window (max 0 (- (buffer-window (outbound)) in-flight-count)))
  553. (stream-ended? (buffer-finished? (outbound)))
  554. (max-advance (- (bit-string-byte-count (buffer-data (outbound))) in-flight-count))
  555. (payload-size (min maximum-segment-size effective-window max-advance)))
  556. (if (and stream-ended? ;; there's a FIN enqueued,
  557. (positive? payload-size) ;; we aren't sending nothing at all,
  558. (= payload-size max-advance)) ;; and our payload would cover the FIN
  559. (values #f (- payload-size 1) #t payload-size)
  560. (values #f payload-size #f payload-size)))
  561. (cond [(= in-flight-count 0) (values #t 0 #f 1)]
  562. [(= in-flight-count 1) (values #t 0 #f 0)]
  563. [else (error 'send-outbound!
  564. "Invalid state: send-next had advanced too far before SYN")])))
  565. (when (and (or (next-expected-seqn) (local-peer-seen?))
  566. ;; ^ Talk only either if: we know the peer's seqn, or
  567. ;; we don't, but a local peer exists, which means
  568. ;; we're an outbound connection rather than a
  569. ;; listener.
  570. (or (transmission-needed?)
  571. (positive? advance))
  572. ;; ^ ... and we have something to say. Something to
  573. ;; ack, or something to send.
  574. )
  575. (define packet-seqn (if mention-syn? (buffer-seqn (outbound)) (send-next)))
  576. (define packet (build-outbound-packet packet-seqn
  577. mention-syn?
  578. mention-fin?
  579. (outbound-data-chunk in-flight-count payload-size)))
  580. (when (positive? advance)
  581. (define new-send-next (seq+ (send-next) advance))
  582. (send-next new-send-next)
  583. (when (seq> new-send-next (high-water-mark))
  584. (high-water-mark new-send-next)))
  585. (when (transmission-needed?)
  586. (transmission-needed? #f))
  587. ;; (log-netstack/tcp-debug " sending ~v" packet)
  588. (send! packet)
  589. ;; (if (> (random) 0.5)
  590. ;; (begin (log-netstack/tcp-debug "Send ~a" (summarize-tcp-packet packet))
  591. ;; (send! packet))
  592. ;; (log-netstack/tcp-debug "Drop ~a" (summarize-tcp-packet packet)))
  593. (when (or mention-syn? mention-fin? (positive? advance))
  594. (when (not (retransmission-deadline))
  595. (arm-retransmission-timer!))
  596. (when (not (rtt-estimate-start-time))
  597. (start-rtt-estimate! (current-inexact-milliseconds))))))
  598. (begin/dataflow
  599. (when (and (retransmission-deadline) (all-output-acknowledged?))
  600. (log-netstack/tcp-debug "All output acknowledged; disarming retransmission timer")
  601. (retransmission-deadline #f)))
  602. (on #:when (retransmission-deadline) (asserted (later-than (retransmission-deadline)))
  603. (send-next (buffer-seqn (outbound)))
  604. (log-netstack/tcp-debug "Retransmission deadline fired, RTO was ~a; reset to ~a"
  605. (retransmission-timeout)
  606. (send-next))
  607. (update-outbound-window! maximum-segment-size) ;; temporary. Will reopen on next ack
  608. (transmission-needed? #t)
  609. (retransmission-deadline #f)
  610. (reset-rtt-estimate!) ;; give up on current RTT estimation
  611. (retransmission-timeout (min 64000 (* 2 (retransmission-timeout))))
  612. (log-netstack/tcp-debug " RTO now ~a" (retransmission-timeout)))
  613. (define (reset! seqn ackn)
  614. (define reset-packet (tcp-packet #f dst-ip dst-port src-ip src-port
  615. seqn
  616. ackn
  617. (set 'ack 'rst)
  618. 0
  619. #""
  620. #""))
  621. (log-netstack/tcp-warning "Reset ~a" (summarize-tcp-packet reset-packet))
  622. (stop-facet root-facet)
  623. (send! reset-packet))
  624. (assert #:when (and (syn-acked?) (not (buffer-finished? (inbound))))
  625. (advertise (tcp-channel src dst _)))
  626. (on-start (log-netstack/tcp-info "Starting state vector ~a-~a" src-port dst-port))
  627. (on-stop (log-netstack/tcp-info "Stopping state vector ~a-~a" src-port dst-port))
  628. (stop-when #:when (and (buffer-finished? (outbound))
  629. (buffer-finished? (inbound))
  630. (all-output-acknowledged?))
  631. (asserted (later-than (+ (latest-peer-activity-time)
  632. (* 2 1000 maximum-segment-lifetime-sec))))
  633. ;; Everything is cleanly shut down, and we just need to wait a while for unexpected
  634. ;; packets before we release the state vector.
  635. )
  636. (stop-when #:when (not (all-output-acknowledged?))
  637. (asserted (later-than (+ (user-timeout-base-time) user-timeout-msec)))
  638. ;; We've been plaintively retransmitting for user-timeout-msec without hearing anything
  639. ;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but
  640. ;; it will do for now? TODO
  641. (log-netstack/tcp-warning "TCP_USER_TIMEOUT fired."))
  642. (define/query-value local-peer-seen? #f (observe (tcp-channel src dst _)) #t
  643. #:on-remove (begin
  644. (log-netstack/tcp-debug "Closing outbound stream.")
  645. (close-outbound-stream!)))
  646. (define/query-value listener-listening?
  647. #f
  648. (observe (advertise (tcp-channel _ (tcp-listener dst-port) _)))
  649. #t)
  650. (define (trigger-ack!)
  651. (transmission-needed? #t))
  652. (on (message (tcp-packet #t src-ip src-port dst-ip dst-port
  653. $seqn $ackn $flags $window $options $data))
  654. (define expected (next-expected-seqn))
  655. (define is-syn? (set-member? flags 'syn))
  656. (define is-fin? (set-member? flags 'fin))
  657. (cond
  658. [(set-member? flags 'rst) (stop-facet root-facet)]
  659. [(and (not expected) ;; no syn yet
  660. (or (not is-syn?) ;; and this isn't it
  661. (and (not (listener-listening?)) ;; or it is, but no listener...
  662. (not (local-peer-seen?))))) ;; ...and no outbound client
  663. (reset! ackn ;; this is *our* seqn
  664. (seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0)))
  665. ;; ^^ this is what we should acknowledge...
  666. )]
  667. [else
  668. (cond
  669. [(not expected) ;; haven't seen syn yet, but we know this is it
  670. (set-inbound-seqn! (seq+ seqn 1))
  671. (incorporate-segment! data)
  672. (trigger-ack!)]
  673. [(= expected seqn)
  674. (incorporate-segment! data)
  675. (when (positive? (bit-string-byte-count data)) (trigger-ack!))]
  676. [else
  677. (trigger-ack!)])
  678. (deliver-inbound-locally!)
  679. (check-fin! flags)
  680. (discard-acknowledged-outbound! (set-member? flags 'ack) ackn)
  681. (update-outbound-window! window)
  682. (latest-peer-activity-time (current-inexact-milliseconds))]))
  683. (on (message (tcp-channel dst src $bs))
  684. ;; (log-netstack/tcp-debug "GOT MORE STUFF TO DELIVER ~v" bs)
  685. (when (all-output-acknowledged?)
  686. ;; Only move user-timeout-base-time if there wasn't
  687. ;; already some outstanding output.
  688. (user-timeout-base-time (current-inexact-milliseconds)))
  689. (outbound (buffer-push (outbound) bs)))))
  690. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  691. (spawn-tcp-driver)