Compare commits
1337 Commits
places-201
...
main
Author | SHA1 | Date |
---|---|---|
Sam Caldwell | 0226b74305 | |
Sam Caldwell | 1607f7df45 | |
Sam Caldwell | e9703a4189 | |
Sam Caldwell | a0e8b59299 | |
Sam Caldwell | 042d667311 | |
Sam Caldwell | 2f17f77d31 | |
Sam Caldwell | b273586616 | |
Sam Caldwell | 26f15564f1 | |
Sam Caldwell | 3801174525 | |
Sam Caldwell | 4ab405fd70 | |
Sam Caldwell | e514453a12 | |
Sam Caldwell | c78cf5bb3d | |
Sam Caldwell | 59042f9180 | |
Sam Caldwell | 28b8bf742f | |
Sam Caldwell | 4808004d64 | |
Sam Caldwell | 45425eb68d | |
Sam Caldwell | 2064bd8f00 | |
Sam Caldwell | 6a7879c06e | |
Sam Caldwell | 643cc4d3ab | |
Sam Caldwell | e4ca56a002 | |
Sam Caldwell | 8af4464443 | |
Sam Caldwell | 0d839cbb12 | |
Sam Caldwell | 7a50ed2f5e | |
Sam Caldwell | 899fe287b4 | |
Sam Caldwell | 3d9b1c383c | |
Sam Caldwell | 7f54c4ccd0 | |
Sam Caldwell | 43cc25ea1b | |
Sam Caldwell | 798e66dc8c | |
Sam Caldwell | 2fb7f4795e | |
Sam Caldwell | b8d580faf3 | |
Sam Caldwell | 28e89297f9 | |
Sam Caldwell | a5e6caaa52 | |
Sam Caldwell | 2057a9f5a9 | |
Sam Caldwell | 3bdace6535 | |
Sam Caldwell | e42460b5e6 | |
Sam Caldwell | 788c9b0e46 | |
Sam Caldwell | c9b25df034 | |
Sam Caldwell | b9f655766f | |
Sam Caldwell | d2e753d303 | |
Sam Caldwell | 29b1171aa8 | |
Sam Caldwell | fc038877f5 | |
Sam Caldwell | e4f72519f0 | |
Sam Caldwell | 2327648499 | |
Sam Caldwell | 6985022a4b | |
Sam Caldwell | ce965d9025 | |
Sam Caldwell | 384d0dbdc1 | |
Sam Caldwell | 06aa3690c7 | |
Sam Caldwell | 6058330961 | |
Sam Caldwell | fe798f72a1 | |
Sam Caldwell | f5f15a5728 | |
Sam Caldwell | 98b773e7ee | |
Sam Caldwell | b4497f1623 | |
Sam Caldwell | 9952ff9400 | |
Sam Caldwell | fd59e58dc3 | |
Sam Caldwell | 481b490fd2 | |
Sam Caldwell | 3ec1048aad | |
Sam Caldwell | 55477446c2 | |
Sam Caldwell | 50cac93e1e | |
Sam Caldwell | fc6e012d1c | |
Sam Caldwell | 3b75881366 | |
Sam Caldwell | 690f9e65a8 | |
Sam Caldwell | 4f6089c805 | |
Sam Caldwell | aa74ffa14d | |
Sam Caldwell | 09ce074125 | |
Sam Caldwell | 3f6a5573e4 | |
Sam Caldwell | 98c58d3e6f | |
Sam Caldwell | c3559f1611 | |
Sam Caldwell | 8b67d0ba03 | |
Sam Caldwell | 52e64d6792 | |
Sam Caldwell | 59183b5fe9 | |
Sam Caldwell | 0191461137 | |
Sam Caldwell | 6b46be34f9 | |
Sam Caldwell | ff1ac58a36 | |
Sam Caldwell | c54b088a4d | |
Sam Caldwell | d5894e400b | |
Sam Caldwell | b023753091 | |
Sam Caldwell | 04530893f4 | |
Sam Caldwell | bd267cfaa9 | |
Sam Caldwell | d79378b4a3 | |
Sam Caldwell | 7a8628880a | |
Sam Caldwell | 145bc84e33 | |
Sam Caldwell | 549590d304 | |
Sam Caldwell | cb3f0546c0 | |
Sam Caldwell | 4e43c489d8 | |
Sam Caldwell | d0f00779cd | |
Sam Caldwell | 5a5c651321 | |
Sam Caldwell | 1fba368987 | |
Sam Caldwell | 7475c1896f | |
Sam Caldwell | 5a90933e9f | |
Sam Caldwell | 8dda1ba6bf | |
Sam Caldwell | 45f140d642 | |
Sam Caldwell | 95699308dd | |
Sam Caldwell | 362e102524 | |
Sam Caldwell | 78fee55ffa | |
Sam Caldwell | 2fd3771609 | |
Sam Caldwell | 8be62ed72c | |
Sam Caldwell | c9c2d2747b | |
Sam Caldwell | c20d075d03 | |
Sam Caldwell | 6dd369b08f | |
Sam Caldwell | c9a5af0d10 | |
Sam Caldwell | 7d8b62ff02 | |
Sam Caldwell | db2a8e1cec | |
Sam Caldwell | 3e13e3e449 | |
Sam Caldwell | 8a6931710a | |
Sam Caldwell | 1805b936be | |
Sam Caldwell | 25860019c6 | |
Sam Caldwell | abecc4996c | |
Sam Caldwell | d523dc7937 | |
Sam Caldwell | e75af5ae1c | |
Sam Caldwell | 4cd90a6295 | |
Sam Caldwell | f040a6db7e | |
Sam Caldwell | e5b797b450 | |
Sam Caldwell | bdf4c30218 | |
Sam Caldwell | 04b58f9d9f | |
Sam Caldwell | b66ab0bfcd | |
Sam Caldwell | 733c874871 | |
Sam Caldwell | fe6435f056 | |
Sam Caldwell | 659715cd0e | |
Sam Caldwell | 8446a0d770 | |
Sam Caldwell | 8288312890 | |
Sam Caldwell | 967da40b80 | |
Sam Caldwell | 1e434f8006 | |
Michael Ballantyne | c988c4f462 | |
Sam Caldwell | db3fc2acd9 | |
Michael Ballantyne | 50d2d1a6fa | |
Sam Caldwell | 122ef0b5f9 | |
Sam Caldwell | e1ca7ba2c4 | |
Sam Caldwell | 27b83e5e0a | |
Sam Caldwell | a1660114df | |
Sam Caldwell | 074ec24da4 | |
Sam Caldwell | 48344856c3 | |
Sam Caldwell | 165dfeb6c8 | |
Sam Caldwell | 38b5e34efb | |
Sam Caldwell | e2bb438704 | |
Sam Caldwell | a6fc1f20e4 | |
Sam Caldwell | 04995b5fb3 | |
Sam Caldwell | 2ba5366986 | |
Sam Caldwell | fc4413ec7a | |
Sam Caldwell | 2cdb894728 | |
Sam Caldwell | 0ed975c58c | |
Sam Caldwell | b59db5b3fd | |
Sam Caldwell | 2a589fcc18 | |
Sam Caldwell | dcd53f5dd5 | |
Sam Caldwell | 0d11850295 | |
Sam Caldwell | 7cf8f9fc0a | |
Sam Caldwell | d30007b798 | |
Sam Caldwell | a5dd55b907 | |
Sam Caldwell | 7e5c8e8eb7 | |
Sam Caldwell | 13e2ec7594 | |
Sam Caldwell | 2e9a0f6394 | |
Sam Caldwell | 5434e82299 | |
Sam Caldwell | 0999c9b75b | |
Sam Caldwell | 30430c391b | |
Sam Caldwell | 060ca752f3 | |
Sam Caldwell | af8dbeaa4b | |
Sam Caldwell | 35d3332698 | |
Sam Caldwell | 9b48e77b6d | |
Sam Caldwell | cc8d0fa30b | |
Sam Caldwell | 98c5c96356 | |
Sam Caldwell | 026e129de7 | |
Sam Caldwell | a2780484be | |
Sam Caldwell | 5c8986bddd | |
Sam Caldwell | 6c79e5cd5c | |
Sam Caldwell | 7ceed8e952 | |
Sam Caldwell | dca8ea2bad | |
Sam Caldwell | b8b5a1747a | |
Sam Caldwell | c38a47f5e3 | |
Sam Caldwell | 480feb961c | |
Sam Caldwell | f8c385e31d | |
Sam Caldwell | dee43c7f19 | |
Sam Caldwell | 18932662de | |
Sam Caldwell | 013ce19e68 | |
Sam Caldwell | f4701a3f70 | |
Stephen Chang | 056d467402 | |
Sam Caldwell | f19d2f3296 | |
Sam Caldwell | f3e2fcdc64 | |
Sam Caldwell | 2a95420366 | |
Sam Caldwell | 7cf0757ca6 | |
Sam Caldwell | 5823cf32c3 | |
Sam Caldwell | 18fdcdeff7 | |
Sam Caldwell | 90961e57f8 | |
Sam Caldwell | 6f8c9563aa | |
Sam Caldwell | 14db8ce919 | |
Sam Caldwell | 79277c91d3 | |
Sam Caldwell | e3d9f93eca | |
Sam Caldwell | 5f472b5402 | |
Sam Caldwell | 35827c970c | |
Sam Caldwell | 8bbab5317e | |
Sam Caldwell | ab15f7306f | |
Sam Caldwell | 606dd17e08 | |
Sam Caldwell | 32ebb804fb | |
Sam Caldwell | 3459fc8f71 | |
Sam Caldwell | 0a5ea2b920 | |
Sam Caldwell | e3d746b817 | |
Sam Caldwell | ed7c212561 | |
Sam Caldwell | 4e6b883c17 | |
Sam Caldwell | c9c3b9ec82 | |
Sam Caldwell | 9c0c9b3e77 | |
Sam Caldwell | 6ee5aa668b | |
Sam Caldwell | ecbfe56163 | |
Sam Caldwell | 7af6782ea8 | |
Sam Caldwell | ce9d563d8c | |
Sam Caldwell | 9e88cde0eb | |
Sam Caldwell | e554c797fb | |
Sam Caldwell | 89e42ae987 | |
Sam Caldwell | 161abab986 | |
Sam Caldwell | ce0dba8f36 | |
Sam Caldwell | 5a5fb74124 | |
Sam Caldwell | 9f8469467a | |
Sam Caldwell | 123124acb2 | |
Sam Caldwell | 7ba1ecf055 | |
Sam Caldwell | 5a19594fa1 | |
Sam Caldwell | 2a72f63084 | |
Sam Caldwell | 63c36d7010 | |
Sam Caldwell | d4b17154eb | |
Sam Caldwell | 5da04741f2 | |
Sam Caldwell | 4d6878626c | |
Sam Caldwell | 712dbd12c9 | |
Sam Caldwell | 9cdaf768d8 | |
Sam Caldwell | de88dc3c83 | |
Sam Caldwell | 5c6b473b62 | |
Sam Caldwell | b3cb16192c | |
Sam Caldwell | 945256b567 | |
Sam Caldwell | cefe70c590 | |
Sam Caldwell | e0d1975e2d | |
Sam Caldwell | d8516060c4 | |
Sam Caldwell | a1ca2372a5 | |
Sam Caldwell | 426b0899ac | |
Sam Caldwell | 1cd46da9d0 | |
Sam Caldwell | 1450665dc0 | |
Sam Caldwell | 9893f4dea1 | |
Sam Caldwell | 7dd9700c99 | |
Sam Caldwell | a41cee09bf | |
Sam Caldwell | 0d4f8df3b4 | |
Sam Caldwell | 116dcefc1a | |
Sam Caldwell | 9b4f76b0ac | |
Sam Caldwell | 989c6af818 | |
Sam Caldwell | d9da970742 | |
Sam Caldwell | 5d922fe030 | |
Sam Caldwell | c1190958bd | |
Sam Caldwell | 57d641dcc3 | |
Sam Caldwell | 397bebe4a3 | |
Sam Caldwell | b0ff2e8620 | |
Sam Caldwell | 6230ed577e | |
Sam Caldwell | 7994bfb9c6 | |
Sam Caldwell | 227768efd8 | |
Sam Caldwell | f20adacfde | |
Sam Caldwell | 67e0eebdc2 | |
Sam Caldwell | 7445626d0b | |
Sam Caldwell | 6778417639 | |
Sam Caldwell | b7ec18e52d | |
Sam Caldwell | 89ce5dca28 | |
Sam Caldwell | b1d14d8559 | |
Sam Caldwell | 7026d6908d | |
Sam Caldwell | 292e16f8b8 | |
Sam Caldwell | 60c58d2b7b | |
Sam Caldwell | d91f13bd2c | |
Sam Caldwell | 5965115611 | |
Sam Caldwell | adc0819be0 | |
Sam Caldwell | 49b34268ad | |
Sam Caldwell | d5a8d27ae3 | |
Sam Caldwell | 4e335f8049 | |
Sam Caldwell | d236d99d47 | |
Sam Caldwell | a0a30c719a | |
Sam Caldwell | cf2162797a | |
Sam Caldwell | 7b9595a22a | |
Sam Caldwell | 667231d3e8 | |
Sam Caldwell | 6b58c20832 | |
Sam Caldwell | b9e99fc8af | |
Sam Caldwell | 45e7ea609d | |
Sam Caldwell | f6976c0281 | |
Sam Caldwell | 0752089101 | |
Sam Caldwell | ad4b94422d | |
Sam Caldwell | b56319042c | |
Sam Caldwell | f4f517cd02 | |
Sam Caldwell | c9378d057d | |
Sam Caldwell | 9cb884a490 | |
Sam Caldwell | e7f792e624 | |
Sam Caldwell | f1be0fdfac | |
Sam Caldwell | 93e1fea202 | |
Sam Caldwell | 16ce86c6c9 | |
Sam Caldwell | c097e218d0 | |
Sam Caldwell | 12fd4ad756 | |
Sam Caldwell | f460011a5d | |
Sam Caldwell | 51e26efda6 | |
Sam Caldwell | 122f7629c3 | |
Sam Caldwell | c96725b8e3 | |
Sam Caldwell | 1feab5d174 | |
Sam Caldwell | 530c17ff32 | |
Sam Caldwell | ed01517c8c | |
Sam Caldwell | 10ae47c26c | |
Sam Caldwell | 6f52c7fc61 | |
Sam Caldwell | 9d5453ff5b | |
Sam Caldwell | f00ec81e48 | |
Sam Caldwell | b1cca8f377 | |
Sam Caldwell | cf17ae28a5 | |
Sam Caldwell | f6cd87394e | |
Sam Caldwell | 39d81686fd | |
Sam Caldwell | 2ddafb240a | |
Sam Caldwell | e88b64f5c1 | |
Sam Caldwell | 82705763b4 | |
Sam Caldwell | 581319eacb | |
Sam Caldwell | 3c800a92db | |
Sam Caldwell | 29c446df39 | |
Sam Caldwell | 006e5e0bf5 | |
Sam Caldwell | f9dcad855e | |
Sam Caldwell | fa7af3444c | |
Sam Caldwell | 58c1b52ac4 | |
Sam Caldwell | d5ac65007e | |
Sam Caldwell | 572be6b45d | |
Sam Caldwell | 5752c9299c | |
Sam Caldwell | 7dfc4a93da | |
Sam Caldwell | ff81748848 | |
Sam Caldwell | f0c52f6eaa | |
Sam Caldwell | e141abd678 | |
Sam Caldwell | d285de5bb2 | |
Sam Caldwell | 04f4acbda3 | |
Sam Caldwell | abce2d6046 | |
Sam Caldwell | d35495029b | |
Tony Garnock-Jones | 38f6351d43 | |
Tony Garnock-Jones | cd98c3048d | |
Tony Garnock-Jones | d1fbe26bc1 | |
Sam Caldwell | a3380ea403 | |
Sam Caldwell | 3957f031c1 | |
Sam Caldwell | f85203ac73 | |
Sam Caldwell | 0da903e438 | |
Sam Caldwell | 22bd143025 | |
Sam Caldwell | a6d6ceaa7c | |
Sam Caldwell | abc8669b74 | |
Sam Caldwell | a98ba7baab | |
Sam Caldwell | 702c53f7d1 | |
Sam Caldwell | bb028b1af8 | |
Sam Caldwell | fb778ab1ee | |
Sam Caldwell | 5cb0462ec4 | |
Sam Caldwell | 0897036557 | |
Sam Caldwell | d363bd0c46 | |
Sam Caldwell | 0c37b4e0b7 | |
Sam Caldwell | c7cc84302e | |
Sam Caldwell | 3a06e2324c | |
Sam Caldwell | 36420274cb | |
Sam Caldwell | c7d78159e3 | |
Sam Caldwell | 7c3d87eeb2 | |
Sam Caldwell | 221a550aed | |
Sam Caldwell | d8df2beb3e | |
Sam Caldwell | 817e292760 | |
Sam Caldwell | 7117816a74 | |
Sam Caldwell | 1b0f41f465 | |
Sam Caldwell | c11d719f20 | |
Sam Caldwell | 70aafc8bdf | |
Sam Caldwell | dcc6bbcbe7 | |
Sam Caldwell | 1b7d5a2330 | |
Sam Caldwell | 1b5cf6d772 | |
Sam Caldwell | 57934b389f | |
Sam Caldwell | 46379858c2 | |
Sam Caldwell | 139e0bcac5 | |
Sam Caldwell | 86330bde03 | |
Sam Caldwell | 0f2469c364 | |
Sam Caldwell | 144e20bdde | |
Sam Caldwell | 5104677fc6 | |
Sam Caldwell | cabb4e2e7c | |
Sam Caldwell | d7fc251bc8 | |
Sam Caldwell | 94823854c0 | |
Sam Caldwell | a9665d93d0 | |
Sam Caldwell | ad2e337268 | |
Sam Caldwell | 00bf7d2364 | |
Sam Caldwell | 632c04139b | |
Sam Caldwell | 6d2d14459c | |
Sam Caldwell | 03285824c7 | |
Sam Caldwell | ddff1c800c | |
Sam Caldwell | c66b62cf46 | |
Sam Caldwell | e7e8f5e174 | |
Sam Caldwell | 938d3c519d | |
Sam Caldwell | 35b3811462 | |
Sam Caldwell | af91b669b7 | |
Sam Caldwell | 5130197e27 | |
Sam Caldwell | 3705d95856 | |
Sam Caldwell | 33af13016b | |
Sam Caldwell | 1a4fc4dd4f | |
Sam Caldwell | e79237b1d3 | |
Sam Caldwell | 4bd8d20b0b | |
Sam Caldwell | 5803b8f9b0 | |
Sam Caldwell | 5bd391dd77 | |
Sam Caldwell | 71c2846a93 | |
Sam Caldwell | 29e09ff3ef | |
Sam Caldwell | 1e66554b8e | |
Sam Caldwell | 8808b5aca9 | |
Sam Caldwell | 5124b8e715 | |
Sam Caldwell | ceb0c60d20 | |
Sam Caldwell | fb675a850c | |
Sam Caldwell | 46a833a66e | |
Sam Caldwell | 5934c1626f | |
Sam Caldwell | 9a3d921de3 | |
Sam Caldwell | cff784384a | |
Sam Caldwell | b1c000e12e | |
Sam Caldwell | 82e5c8504c | |
Tony Garnock-Jones | 47094c11c4 | |
Tony Garnock-Jones | eb70563edb | |
Tony Garnock-Jones | c564bd28ec | |
Tony Garnock-Jones | cb351eee09 | |
Sam Caldwell | 7d9f505fc6 | |
Sam Caldwell | e402725d7f | |
Sam Caldwell | f1c51661c7 | |
Tony Garnock-Jones | f64ad8389a | |
Tony Garnock-Jones | 06224b52a8 | |
Tony Garnock-Jones | 1fa5167e20 | |
Tony Garnock-Jones | 55e1f09484 | |
Tony Garnock-Jones | af150712e0 | |
Tony Garnock-Jones | 57a40e9576 | |
Tony Garnock-Jones | 62f8385b24 | |
Tony Garnock-Jones | 22d837d6a4 | |
Tony Garnock-Jones | 1ab4f0f525 | |
Tony Garnock-Jones | f11f4fd054 | |
Tony Garnock-Jones | eb44003317 | |
Tony Garnock-Jones | eb564fdb7c | |
Tony Garnock-Jones | c9ec9f6be9 | |
Tony Garnock-Jones | 75093d0e1a | |
Tony Garnock-Jones | 1dbab91ccc | |
Tony Garnock-Jones | 53e26b08a1 | |
Sam Tobin-Hochstadt | 87495bdc37 | |
Tony Garnock-Jones | 710e75dffa | |
Tony Garnock-Jones | d51a513f8b | |
Tony Garnock-Jones | bf0eb16643 | |
Tony Garnock-Jones | 8999b8446d | |
Tony Garnock-Jones | fa82634868 | |
Tony Garnock-Jones | 45eee62fc2 | |
Tony Garnock-Jones | 5904a2f956 | |
Tony Garnock-Jones | 32d1274a8d | |
Tony Garnock-Jones | 18b3ab0d97 | |
Tony Garnock-Jones | fc0e900485 | |
Tony Garnock-Jones | 0526364698 | |
Tony Garnock-Jones | 70a56e6457 | |
Tony Garnock-Jones | 22998de0dc | |
Tony Garnock-Jones | 801470ebaa | |
Tony Garnock-Jones | 66e2e8b1a7 | |
Tony Garnock-Jones | 14f1cbd4fa | |
Tony Garnock-Jones | 275b60310f | |
Tony Garnock-Jones | ca0de7d52f | |
Tony Garnock-Jones | 16bd0155cc | |
Tony Garnock-Jones | eb07be548e | |
Tony Garnock-Jones | 5254feb4de | |
Tony Garnock-Jones | db333a266f | |
Tony Garnock-Jones | d96477b9db | |
Tony Garnock-Jones | 0599f974b9 | |
Tony Garnock-Jones | 4f52ebf108 | |
Tony Garnock-Jones | fa257a1d16 | |
Tony Garnock-Jones | 7a4d528dc0 | |
Tony Garnock-Jones | 4a51141500 | |
Tony Garnock-Jones | 51ab2921c2 | |
Tony Garnock-Jones | e41290c509 | |
Tony Garnock-Jones | 6c4ae38499 | |
Tony Garnock-Jones | 4a4f43b2cb | |
Tony Garnock-Jones | 903ed5deaa | |
Tony Garnock-Jones | 2a5d8ebdd4 | |
Tony Garnock-Jones | 96331e0cfd | |
Tony Garnock-Jones | e124983e05 | |
Tony Garnock-Jones | a82b428f44 | |
Tony Garnock-Jones | 516f6a5cd2 | |
Tony Garnock-Jones | 6a436f4c12 | |
Tony Garnock-Jones | 5ce1cec2ea | |
Tony Garnock-Jones | d0e803ac41 | |
Tony Garnock-Jones | 0acd504d05 | |
Tony Garnock-Jones | e0dc583f51 | |
Tony Garnock-Jones | 2a0197b711 | |
Tony Garnock-Jones | 930e4270b4 | |
Tony Garnock-Jones | 88d324929d | |
Tony Garnock-Jones | 8cbabafbab | |
Tony Garnock-Jones | cb3eee64dc | |
Tony Garnock-Jones | b2e2674f44 | |
Tony Garnock-Jones | 3db51ffda5 | |
Tony Garnock-Jones | fdcd9b9388 | |
Tony Garnock-Jones | e2d1ae853c | |
Tony Garnock-Jones | af30c19ee0 | |
Tony Garnock-Jones | f3b5fd6cd1 | |
Tony Garnock-Jones | 6728fcf10d | |
Tony Garnock-Jones | 09d0fb620d | |
Tony Garnock-Jones | 84ec153a1e | |
Tony Garnock-Jones | 4efe18bfe0 | |
Tony Garnock-Jones | 9009fb5ec7 | |
Tony Garnock-Jones | 40961e7893 | |
Tony Garnock-Jones | b3a745dbcb | |
Tony Garnock-Jones | c9996d53ae | |
Tony Garnock-Jones | 837ab77002 | |
Tony Garnock-Jones | 6b3f8d920a | |
Tony Garnock-Jones | 61b683fc94 | |
Tony Garnock-Jones | 4f8bc6e5af | |
Tony Garnock-Jones | 6703c5ef9a | |
Tony Garnock-Jones | a4ae0ae270 | |
Tony Garnock-Jones | 4f21e9ab46 | |
Tony Garnock-Jones | 5bff630547 | |
Tony Garnock-Jones | f83f286e28 | |
Tony Garnock-Jones | 11de40ce98 | |
Tony Garnock-Jones | f9a477832a | |
Tony Garnock-Jones | 1e42059c0f | |
Tony Garnock-Jones | 81bd857259 | |
Tony Garnock-Jones | 0719d78ca8 | |
Tony Garnock-Jones | 38032448bd | |
Tony Garnock-Jones | 203de5807f | |
Tony Garnock-Jones | 24ac40b251 | |
Tony Garnock-Jones | 75aee96e1a | |
Tony Garnock-Jones | aaa395df3a | |
Tony Garnock-Jones | eeb655a0ac | |
Tony Garnock-Jones | 6b2ee53fa8 | |
Tony Garnock-Jones | e864ca4c2c | |
Tony Garnock-Jones | 194c8013b1 | |
Sam Caldwell | 5f621b098e | |
Tony Garnock-Jones | 852e93328f | |
Tony Garnock-Jones | 8de523d8ee | |
Tony Garnock-Jones | 0e28e4c572 | |
Tony Garnock-Jones | 81a0351828 | |
Tony Garnock-Jones | 6e399dd1dd | |
Tony Garnock-Jones | 28f6b8acf8 | |
Tony Garnock-Jones | b189a249f8 | |
Tony Garnock-Jones | 7ddcebfddb | |
Tony Garnock-Jones | a090ed8330 | |
Tony Garnock-Jones | 8a2ace112b | |
Tony Garnock-Jones | f6c145b4a7 | |
Tony Garnock-Jones | 46e5922dc8 | |
Tony Garnock-Jones | 6db1e67a7e | |
Tony Garnock-Jones | 76c1a5b347 | |
Tony Garnock-Jones | 990ad4ca72 | |
Tony Garnock-Jones | 3073d8b614 | |
Tony Garnock-Jones | 37cee0c937 | |
Tony Garnock-Jones | ac5c5d2e5f | |
Tony Garnock-Jones | 1fdd62d56d | |
Tony Garnock-Jones | 46fd5e2b92 | |
Tony Garnock-Jones | 9b54069ecd | |
Tony Garnock-Jones | 42742fe8ac | |
Tony Garnock-Jones | 966cd2ed17 | |
Tony Garnock-Jones | 4be0a8cb59 | |
Tony Garnock-Jones | b9dfd79f34 | |
Sam Caldwell | 6448188e82 | |
Sam Caldwell | 9498f5129e | |
Tony Garnock-Jones | 425a5abac3 | |
Sam Caldwell | c15b75ecae | |
Sam Caldwell | d4f95d3a7b | |
Sam Caldwell | 460d72d69e | |
Sam Caldwell | a8421f3929 | |
Sam Caldwell | 36ff30c289 | |
Sam Caldwell | da422ff117 | |
Sam Caldwell | 88f515a98f | |
Sam Caldwell | fb3918404c | |
Sam Caldwell | 6ee97839fa | |
Sam Caldwell | e57af91698 | |
Sam Caldwell | 318363f4be | |
Sam Caldwell | c8cc8051a1 | |
Sam Caldwell | 34c3b6bf3a | |
Sam Caldwell | 90bf07f6d4 | |
Sam Caldwell | 079e2da53d | |
Sam Caldwell | df40cc7ba9 | |
Sam Caldwell | 3986f4d0ea | |
Sam Caldwell | e1671ce878 | |
Sam Caldwell | da1f9d4b6d | |
Sam Caldwell | 5544052488 | |
Sam Caldwell | 7b1c102224 | |
Sam Caldwell | 1be415eb45 | |
Sam Caldwell | 53cd60f196 | |
Sam Caldwell | f19a02e859 | |
Sam Caldwell | 5a87428f62 | |
Tony Garnock-Jones | 118cdef4c6 | |
Tony Garnock-Jones | 689d410bda | |
Tony Garnock-Jones | 66667d9fe6 | |
Tony Garnock-Jones | cddce5a02b | |
Sam Caldwell | e0e7baed46 | |
Tony Garnock-Jones | dc83d33afb | |
Tony Garnock-Jones | c51f18efc2 | |
Sam Caldwell | 921b84e056 | |
Tony Garnock-Jones | ea1b1bc072 | |
Tony Garnock-Jones | 6f70eaf93e | |
Tony Garnock-Jones | ee52520a13 | |
Sam Caldwell | 783d132f25 | |
Sam Caldwell | 99ccc12fee | |
Sam Caldwell | 27cb9ba983 | |
Sam Caldwell | 1f4bf075b7 | |
Tony Garnock-Jones | 1bfc4bbdad | |
Tony Garnock-Jones | d2bd2cd63e | |
Tony Garnock-Jones | aff57a1247 | |
Tony Garnock-Jones | e61dbf19f6 | |
Tony Garnock-Jones | 6d8ced489c | |
Tony Garnock-Jones | deefa251d9 | |
Tony Garnock-Jones | 1f8bb56c69 | |
Sam Caldwell | 1134ed0eff | |
Sam Caldwell | 9c1e9719ba | |
Tony Garnock-Jones | 413840382b | |
Sam Caldwell | 2b19064960 | |
Tony Garnock-Jones | 25729454a6 | |
Tony Garnock-Jones | 36459c5942 | |
Tony Garnock-Jones | 6adcf81c0d | |
Tony Garnock-Jones | e593cf768b | |
Tony Garnock-Jones | 19bebc9881 | |
Tony Garnock-Jones | eb4a228c73 | |
Tony Garnock-Jones | 7cc62688f9 | |
Tony Garnock-Jones | 9b50df1570 | |
Tony Garnock-Jones | 2f5f4c8d8d | |
Tony Garnock-Jones | 4d2252b90a | |
Tony Garnock-Jones | 038ea39b30 | |
Tony Garnock-Jones | 4454fe4c03 | |
Tony Garnock-Jones | b946bbec3c | |
Tony Garnock-Jones | 4940c0b372 | |
Tony Garnock-Jones | 6a2163bce9 | |
Tony Garnock-Jones | 75bc4a8ca5 | |
Tony Garnock-Jones | 7067c06961 | |
Tony Garnock-Jones | c7db9f2543 | |
Tony Garnock-Jones | f13fc9cad3 | |
Tony Garnock-Jones | bf20d84935 | |
Tony Garnock-Jones | 132032b602 | |
Tony Garnock-Jones | b87639b7a4 | |
Tony Garnock-Jones | d9905df4e5 | |
Tony Garnock-Jones | f440911e7f | |
Tony Garnock-Jones | 985403894f | |
Tony Garnock-Jones | 88ff347744 | |
Tony Garnock-Jones | db0282ca72 | |
Tony Garnock-Jones | cbdc19fc8e | |
Tony Garnock-Jones | c019a61c18 | |
Tony Garnock-Jones | 64cfce2472 | |
Tony Garnock-Jones | 51a28b9349 | |
Tony Garnock-Jones | 26d4a75318 | |
Tony Garnock-Jones | 803e3f6fd5 | |
Tony Garnock-Jones | 4ee234f118 | |
Tony Garnock-Jones | 73e0ba315a | |
Tony Garnock-Jones | 6af0ec70c8 | |
Tony Garnock-Jones | 0facbc90b3 | |
Tony Garnock-Jones | c2ece35bf9 | |
Tony Garnock-Jones | 78cb6f0c02 | |
Tony Garnock-Jones | 97b194487b | |
Tony Garnock-Jones | ae6c5a409f | |
Tony Garnock-Jones | 97bb848611 | |
Tony Garnock-Jones | d0d7e677fe | |
Tony Garnock-Jones | d9cc478e6c | |
Tony Garnock-Jones | 8cd60417c4 | |
Tony Garnock-Jones | 726b936ed3 | |
Tony Garnock-Jones | 02c0af4c75 | |
Tony Garnock-Jones | 885a1d05d6 | |
Tony Garnock-Jones | 9bb831cac5 | |
Tony Garnock-Jones | f677c3a888 | |
Tony Garnock-Jones | 3a3d216908 | |
Tony Garnock-Jones | bde2d833bd | |
Tony Garnock-Jones | f638923c6f | |
Tony Garnock-Jones | 05c57ec05d | |
Tony Garnock-Jones | c77513e838 | |
Tony Garnock-Jones | e7402e4387 | |
Tony Garnock-Jones | 260a99e08b | |
Tony Garnock-Jones | bab5aba083 | |
Tony Garnock-Jones | 8202220fec | |
Tony Garnock-Jones | 2f7313a489 | |
Tony Garnock-Jones | ad2874f463 | |
Tony Garnock-Jones | 8f181f5b4d | |
Tony Garnock-Jones | b72fca51b0 | |
Tony Garnock-Jones | f1a7e10fbf | |
Tony Garnock-Jones | 7b5b866a6d | |
Tony Garnock-Jones | 16d9dd27c9 | |
Tony Garnock-Jones | 990ae8ea9a | |
Tony Garnock-Jones | 0a585d7842 | |
Tony Garnock-Jones | 4af472f7ff | |
Tony Garnock-Jones | a3335800f6 | |
Tony Garnock-Jones | f201bea5c6 | |
Tony Garnock-Jones | f0f29007df | |
Tony Garnock-Jones | 257c0bf628 | |
Tony Garnock-Jones | 0d34e3280e | |
Tony Garnock-Jones | 3ce8bc380b | |
Tony Garnock-Jones | 4b99b629df | |
Tony Garnock-Jones | 97a843ccec | |
Tony Garnock-Jones | c302e35024 | |
Tony Garnock-Jones | 0102a7d1cd | |
Tony Garnock-Jones | 6497cc5185 | |
Tony Garnock-Jones | 4d6a2986d5 | |
Tony Garnock-Jones | c8b7be22cc | |
Tony Garnock-Jones | 9d34ffea4f | |
Tony Garnock-Jones | b2c795c57a | |
Tony Garnock-Jones | c595c638b2 | |
Tony Garnock-Jones | a7a2a5c492 | |
Tony Garnock-Jones | c6ca757a7e | |
Tony Garnock-Jones | 08f1e7506b | |
Tony Garnock-Jones | bc346ff38a | |
Tony Garnock-Jones | 594bb3989b | |
Tony Garnock-Jones | c77793f7fd | |
Tony Garnock-Jones | 15504cccab | |
Tony Garnock-Jones | 490e414904 | |
Tony Garnock-Jones | d442f4890f | |
Tony Garnock-Jones | 4a39a03a0a | |
Tony Garnock-Jones | c9eddfa0b7 | |
Tony Garnock-Jones | 2d1ad8a62d | |
Tony Garnock-Jones | 37af1e8726 | |
Tony Garnock-Jones | ea997539a2 | |
Tony Garnock-Jones | e90c0e580e | |
Tony Garnock-Jones | acd9dde2b8 | |
Tony Garnock-Jones | cd83b5f5d8 | |
Tony Garnock-Jones | 171a51d68c | |
Tony Garnock-Jones | e0ce5eb5b4 | |
Tony Garnock-Jones | 0f3db4eac6 | |
Tony Garnock-Jones | d1c858a7ae | |
Tony Garnock-Jones | 773d1e953b | |
Tony Garnock-Jones | d00f0cbf13 | |
Tony Garnock-Jones | 4ea2586666 | |
Tony Garnock-Jones | be7cf7417d | |
Tony Garnock-Jones | 39e46c1cfa | |
Tony Garnock-Jones | 8f28ae0e9c | |
Tony Garnock-Jones | 694de50bc0 | |
Tony Garnock-Jones | c1681f7804 | |
Tony Garnock-Jones | e7dc36f126 | |
Tony Garnock-Jones | 9a62eb6076 | |
Tony Garnock-Jones | aab25684b8 | |
Tony Garnock-Jones | 7be8eb6d60 | |
Tony Garnock-Jones | 9080396bc5 | |
Tony Garnock-Jones | bb889542fc | |
Tony Garnock-Jones | 7633174562 | |
Tony Garnock-Jones | abba2719fd | |
Tony Garnock-Jones | 9ee7e677ad | |
Tony Garnock-Jones | c844c0d596 | |
Tony Garnock-Jones | 02828d8356 | |
Tony Garnock-Jones | 0ef2a621d1 | |
Tony Garnock-Jones | 497b63699c | |
Tony Garnock-Jones | 550bb12c4a | |
Tony Garnock-Jones | 7880b2ba28 | |
Tony Garnock-Jones | 7d52e24a35 | |
Tony Garnock-Jones | 74b768044f | |
Tony Garnock-Jones | 9f333345fc | |
Tony Garnock-Jones | 92ae08b24e | |
Tony Garnock-Jones | c459dbe684 | |
Tony Garnock-Jones | c758c0d79c | |
Tony Garnock-Jones | 9451c6ca54 | |
Tony Garnock-Jones | 01013ea372 | |
Tony Garnock-Jones | 82e4b64168 | |
Tony Garnock-Jones | bd40ca3c62 | |
Tony Garnock-Jones | 386df02fd0 | |
Tony Garnock-Jones | b56f559f45 | |
Tony Garnock-Jones | 45c12bacf0 | |
Tony Garnock-Jones | e50ab77b53 | |
Tony Garnock-Jones | a6f002c27d | |
Tony Garnock-Jones | b60fa8c755 | |
Tony Garnock-Jones | 1ae40c1ff1 | |
Tony Garnock-Jones | b69c3b3778 | |
Tony Garnock-Jones | 8249993a86 | |
Tony Garnock-Jones | 4685d6af46 | |
Tony Garnock-Jones | bf3b2a5a36 | |
Tony Garnock-Jones | e76ccd31a2 | |
Tony Garnock-Jones | fb3ed65831 | |
Tony Garnock-Jones | ca1c0f6645 | |
Tony Garnock-Jones | 2a6061bd97 | |
Tony Garnock-Jones | 138bab9ba6 | |
Tony Garnock-Jones | c61ed644ce | |
Tony Garnock-Jones | 0bc775a89f | |
Tony Garnock-Jones | 56e893fac4 | |
Tony Garnock-Jones | 3240f20d90 | |
Tony Garnock-Jones | 4beb281a2d | |
Tony Garnock-Jones | 426a38b17f | |
Tony Garnock-Jones | fe47abd540 | |
Tony Garnock-Jones | a890a7147b | |
Tony Garnock-Jones | 956a940480 | |
Tony Garnock-Jones | 6684c9e883 | |
Tony Garnock-Jones | 0bc370beec | |
Tony Garnock-Jones | a828334b2f | |
Tony Garnock-Jones | 2b29e817a5 | |
Tony Garnock-Jones | f20d1a2ad7 | |
Tony Garnock-Jones | d7a594e2b9 | |
Tony Garnock-Jones | 3de86c3b29 | |
Tony Garnock-Jones | 7df50fbac9 | |
Tony Garnock-Jones | a55dc6ec58 | |
Tony Garnock-Jones | 31ee867964 | |
Tony Garnock-Jones | 5dc1d99a3b | |
Tony Garnock-Jones | 747e96714d | |
Tony Garnock-Jones | 6443e9dadd | |
Tony Garnock-Jones | e3520ac711 | |
Tony Garnock-Jones | 2c78d1ad0a | |
Tony Garnock-Jones | 3977e57b38 | |
Tony Garnock-Jones | eaade6e4fd | |
Tony Garnock-Jones | cd754be396 | |
Tony Garnock-Jones | 7f785008c8 | |
Tony Garnock-Jones | 183f104ade | |
Tony Garnock-Jones | add689623e | |
Tony Garnock-Jones | 41693b897c | |
Tony Garnock-Jones | e2575c3ea1 | |
Tony Garnock-Jones | f3631ed18f | |
Tony Garnock-Jones | ba2f4d677d | |
Tony Garnock-Jones | 8b63c68673 | |
Tony Garnock-Jones | 02c66c4bab | |
Sam Caldwell | 73f180d90a | |
Tony Garnock-Jones | c9ae956bd2 | |
Tony Garnock-Jones | 4138495ae1 | |
Tony Garnock-Jones | e22f608109 | |
Tony Garnock-Jones | 4e1bab4b90 | |
Tony Garnock-Jones | 1fa50e4e6a | |
Tony Garnock-Jones | 628b7b2356 | |
Tony Garnock-Jones | e2897d37f4 | |
Tony Garnock-Jones | e36777584c | |
Tony Garnock-Jones | 463dd48577 | |
Tony Garnock-Jones | dd246ddcae | |
Tony Garnock-Jones | f34924bc6d | |
Tony Garnock-Jones | 15b5406932 | |
Tony Garnock-Jones | 8f0ba7625b | |
Tony Garnock-Jones | 4dad3e9661 | |
Tony Garnock-Jones | 06ddbe060e | |
Tony Garnock-Jones | 5f48f3ba0c | |
Tony Garnock-Jones | 9e3f804aae | |
Tony Garnock-Jones | b6a03bdd9b | |
Tony Garnock-Jones | 3edd184242 | |
Tony Garnock-Jones | c7dae47210 | |
Tony Garnock-Jones | 07eb91b0d9 | |
Tony Garnock-Jones | 17db697690 | |
Tony Garnock-Jones | c0786c86ca | |
Tony Garnock-Jones | 68ba2f74a6 | |
Tony Garnock-Jones | b8c109d82b | |
Tony Garnock-Jones | 2a2d363c5e | |
Tony Garnock-Jones | 129dd23b84 | |
Tony Garnock-Jones | 7a3973a097 | |
Tony Garnock-Jones | 9241775879 | |
Tony Garnock-Jones | 56d2fc2c0d | |
Tony Garnock-Jones | 0cff79abec | |
Sam Caldwell | 2e24e105b8 | |
Tony Garnock-Jones | be157decce | |
Tony Garnock-Jones | eabf9be37b | |
Sam Caldwell | 48763d8dbe | |
Tony Garnock-Jones | 7f930311ce | |
Tony Garnock-Jones | e99cd0887f | |
Tony Garnock-Jones | 05325c2699 | |
Tony Garnock-Jones | eb27d6acc5 | |
Tony Garnock-Jones | d67d490885 | |
Tony Garnock-Jones | 8dba9a66c6 | |
Tony Garnock-Jones | 8e22e58920 | |
Tony Garnock-Jones | a05d486354 | |
Sam Caldwell | ce80efeb85 | |
Sam Caldwell | fdf0fa8cf6 | |
Tony Garnock-Jones | 6cac704bc5 | |
Tony Garnock-Jones | 819ff13835 | |
Tony Garnock-Jones | 796acbeea2 | |
Tony Garnock-Jones | b6e863fa79 | |
Tony Garnock-Jones | 981914c15b | |
Sam Caldwell | c714374685 | |
Sam Caldwell | 9a6ce7d7f9 | |
Sam Caldwell | e20506644f | |
Sam Caldwell | f28e16ee7b | |
Sam Caldwell | 9f8ddc5249 | |
Tony Garnock-Jones | cecb261c6b | |
Tony Garnock-Jones | 5aebc7fa75 | |
Tony Garnock-Jones | c931b0aee5 | |
Tony Garnock-Jones | c146f1d3b9 | |
Tony Garnock-Jones | d33d2f42a3 | |
Tony Garnock-Jones | b2d5a3f74d | |
Tony Garnock-Jones | e1ddeb5f90 | |
Tony Garnock-Jones | e0f3650989 | |
Tony Garnock-Jones | e165972a03 | |
Tony Garnock-Jones | 75ef296c58 | |
Tony Garnock-Jones | 71b8edf5c3 | |
Tony Garnock-Jones | 015d7c38dd | |
Tony Garnock-Jones | 09dfaf7d0e | |
Tony Garnock-Jones | 04f1c56a5a | |
Tony Garnock-Jones | ec2996e931 | |
Tony Garnock-Jones | b444bccb80 | |
Tony Garnock-Jones | fb5b6e80b8 | |
Tony Garnock-Jones | 4357424e78 | |
Tony Garnock-Jones | 970baf7a36 | |
Tony Garnock-Jones | bffc3757cb | |
Tony Garnock-Jones | 573ca4d6e5 | |
Tony Garnock-Jones | ccdaceb30c | |
Tony Garnock-Jones | 3569426048 | |
Tony Garnock-Jones | 9b5a399383 | |
Tony Garnock-Jones | 815b139e5c | |
Tony Garnock-Jones | a01480fe05 | |
Sam Caldwell | c76480f701 | |
Sam Caldwell | 01ad7c72f6 | |
Sam Caldwell | 3b9e483076 | |
Sam Caldwell | e20f87adba | |
Sam Caldwell | 9cf12a381e | |
Sam Caldwell | 0fb5fa52f4 | |
Tony Garnock-Jones | a046bd0f23 | |
Tony Garnock-Jones | 21f05e110a | |
Tony Garnock-Jones | 0a0feee01b | |
Tony Garnock-Jones | 1334bd3abb | |
Tony Garnock-Jones | d36ccbb0c2 | |
Tony Garnock-Jones | 4f570fcd18 | |
Tony Garnock-Jones | 4496258d0e | |
Tony Garnock-Jones | b6c679afa6 | |
Sam Caldwell | 75cec37038 | |
Sam Caldwell | e1f42d5d4f | |
Tony Garnock-Jones | 22f5c47d30 | |
Tony Garnock-Jones | cb473a8847 | |
Tony Garnock-Jones | 0ac24a5755 | |
Tony Garnock-Jones | 024cb6d707 | |
Tony Garnock-Jones | 95fe020ed1 | |
Tony Garnock-Jones | fe272ab514 | |
Tony Garnock-Jones | 6c3295c96d | |
Tony Garnock-Jones | 53efb1fcd4 | |
Tony Garnock-Jones | be80ac038f | |
Tony Garnock-Jones | a466fcdf23 | |
Tony Garnock-Jones | cf82b794e5 | |
Tony Garnock-Jones | 1a6199f9ee | |
Tony Garnock-Jones | 34b504326f | |
Tony Garnock-Jones | 7989bc4931 | |
Tony Garnock-Jones | 0b06bcf1c4 | |
Tony Garnock-Jones | e8d33d4135 | |
Tony Garnock-Jones | 2afa0fce15 | |
Tony Garnock-Jones | 7c11a438e4 | |
Tony Garnock-Jones | 118c163193 | |
Tony Garnock-Jones | 6fae78c7c6 | |
Tony Garnock-Jones | 0314f6a400 | |
Tony Garnock-Jones | cca195d597 | |
Tony Garnock-Jones | 9644aa3ad1 | |
Tony Garnock-Jones | b323d7c650 | |
Tony Garnock-Jones | 3f3249e7a1 | |
Tony Garnock-Jones | adf6603440 | |
Tony Garnock-Jones | b20337fad8 | |
Tony Garnock-Jones | 081383d321 | |
Tony Garnock-Jones | 5484e1b4a3 | |
Tony Garnock-Jones | adf2d1e291 | |
Tony Garnock-Jones | 9bf2991da8 | |
Tony Garnock-Jones | 175c619edc | |
Tony Garnock-Jones | bf12d3f27f | |
Tony Garnock-Jones | 1e1fef6a6e | |
Tony Garnock-Jones | 3bc95aeaeb | |
Tony Garnock-Jones | 8ca2b1ac0c | |
Tony Garnock-Jones | 52aed3111c | |
Tony Garnock-Jones | d244866617 | |
Tony Garnock-Jones | 31ee4cb2cd | |
Tony Garnock-Jones | 707245cfe2 | |
Tony Garnock-Jones | 173a0edb54 | |
Tony Garnock-Jones | c8f2ea8a56 | |
Tony Garnock-Jones | 95c17a190c | |
Tony Garnock-Jones | e5a38d5fe5 | |
Tony Garnock-Jones | eac9f39169 | |
Tony Garnock-Jones | 7cc8f2cbe6 | |
Tony Garnock-Jones | 4ae9aa0e2b | |
Tony Garnock-Jones | b857ce7bcd | |
Tony Garnock-Jones | f21e58dacb | |
Tony Garnock-Jones | 7271ef6b73 | |
Tony Garnock-Jones | 0b2d80a997 | |
Tony Garnock-Jones | 9b2ce64300 | |
Tony Garnock-Jones | ddd67540be | |
Tony Garnock-Jones | 03616226e1 | |
Tony Garnock-Jones | dcd8819778 | |
Tony Garnock-Jones | 0b964bb1bb | |
Tony Garnock-Jones | 7e144ab33b | |
Tony Garnock-Jones | 403cc372c1 | |
Tony Garnock-Jones | d161d50b9a | |
Tony Garnock-Jones | 2a218dd0a6 | |
Tony Garnock-Jones | e74f6ae7e5 | |
Tony Garnock-Jones | cd94df3cab | |
Tony Garnock-Jones | f4d1f5c800 | |
Tony Garnock-Jones | 02f4f9f89c | |
Tony Garnock-Jones | dd28b667e8 | |
Tony Garnock-Jones | 56324db6f6 | |
Tony Garnock-Jones | 736c93ea94 | |
Tony Garnock-Jones | f8116ee8eb | |
Tony Garnock-Jones | 9af4e88681 | |
Tony Garnock-Jones | 9cee74b290 | |
Tony Garnock-Jones | f3645b9081 | |
Tony Garnock-Jones | f6ed330a0d | |
Tony Garnock-Jones | 4d905e9f3f | |
Tony Garnock-Jones | d4e4cc6bd6 | |
Tony Garnock-Jones | eef8e09f11 | |
Tony Garnock-Jones | 4aabe422fe | |
Tony Garnock-Jones | e806e91baa | |
Tony Garnock-Jones | 02d73f44fa | |
Tony Garnock-Jones | 4c1d6814d9 | |
Tony Garnock-Jones | fba4aaa6b4 | |
Tony Garnock-Jones | 6160012576 | |
Tony Garnock-Jones | b559ab04f8 | |
Tony Garnock-Jones | 9312a28226 | |
Tony Garnock-Jones | f83f4c6413 | |
Tony Garnock-Jones | 8256b56607 | |
Tony Garnock-Jones | 1f33039e28 | |
Tony Garnock-Jones | 5ec89bd987 | |
Tony Garnock-Jones | f663409609 | |
Tony Garnock-Jones | acca81076a | |
Tony Garnock-Jones | e27e028d8c | |
Tony Garnock-Jones | 43f6bd39ea | |
Tony Garnock-Jones | aed3a9f1e2 | |
Tony Garnock-Jones | 3d13375b20 | |
Tony Garnock-Jones | 2c351d7352 | |
Tony Garnock-Jones | 299be35d8f | |
Tony Garnock-Jones | 9e673c1588 | |
Tony Garnock-Jones | 7a759de5a1 | |
Tony Garnock-Jones | 5c80c2f3bd | |
Tony Garnock-Jones | a7ad6355f5 | |
Tony Garnock-Jones | eafcff8f75 | |
Sam Caldwell | e18b2a8062 | |
Sam Caldwell | d316449538 | |
Tony Garnock-Jones | 4acb32813e | |
Tony Garnock-Jones | 5c288036aa | |
Tony Garnock-Jones | 791d2880ae | |
Tony Garnock-Jones | 1e84a3507d | |
Tony Garnock-Jones | e3ff45b08e | |
Tony Garnock-Jones | 07ef4f108e | |
Tony Garnock-Jones | b1f7816418 | |
Tony Garnock-Jones | 3db6177ce9 | |
Tony Garnock-Jones | d9b11566f5 | |
Tony Garnock-Jones | c7b62b109e | |
Tony Garnock-Jones | df7908d5a7 | |
Tony Garnock-Jones | 1aead77a72 | |
Tony Garnock-Jones | 61ca89ce04 | |
Tony Garnock-Jones | 152a76af5e | |
Tony Garnock-Jones | b92c439f07 | |
Tony Garnock-Jones | 6a204a9085 | |
Tony Garnock-Jones | 51d9d4b64e | |
Tony Garnock-Jones | cd60353053 | |
Tony Garnock-Jones | 74c663d5d4 | |
Tony Garnock-Jones | 81f9a0f0fe | |
Tony Garnock-Jones | c29ae059ff | |
Tony Garnock-Jones | 0f1fabddfb | |
Tony Garnock-Jones | 931c54df6a | |
Tony Garnock-Jones | 1f8b3eeb3f | |
Tony Garnock-Jones | 097641ffff | |
Tony Garnock-Jones | 0653bdae3c | |
Tony Garnock-Jones | a55ed180db | |
Tony Garnock-Jones | b65291e789 | |
Tony Garnock-Jones | e7b0e15786 | |
Tony Garnock-Jones | ee120022a4 | |
Tony Garnock-Jones | e55e19d5e4 | |
Tony Garnock-Jones | 0561a02e78 | |
Tony Garnock-Jones | 7a4f1d8931 | |
Tony Garnock-Jones | c7d91ac37f | |
Tony Garnock-Jones | bf532edd28 | |
Tony Garnock-Jones | 16365e7e95 | |
Tony Garnock-Jones | 35f0b75389 | |
Tony Garnock-Jones | cfd7312293 | |
Tony Garnock-Jones | deae6c6d29 | |
Tony Garnock-Jones | 372652c49d | |
Tony Garnock-Jones | f64491c0a7 | |
Tony Garnock-Jones | 628ba87c54 | |
Tony Garnock-Jones | 68cde5be6c | |
Tony Garnock-Jones | b51e7f99d9 | |
Tony Garnock-Jones | 6d305e6b00 | |
Tony Garnock-Jones | a433a054b8 | |
Tony Garnock-Jones | e0bd8d08c2 | |
Tony Garnock-Jones | 4eb29832df | |
Tony Garnock-Jones | fb89954158 | |
Tony Garnock-Jones | c6cfa2fe87 | |
Tony Garnock-Jones | f486f93bd4 | |
Tony Garnock-Jones | 81e10632dd | |
Tony Garnock-Jones | 7e48e82a48 | |
Tony Garnock-Jones | de44b51e49 | |
Tony Garnock-Jones | a8821913a1 | |
Tony Garnock-Jones | 4de4a099b9 | |
Tony Garnock-Jones | 8d6bc484a8 | |
Tony Garnock-Jones | 7b26b4bf14 | |
Tony Garnock-Jones | 879e2425b9 | |
Tony Garnock-Jones | e67d018079 | |
Tony Garnock-Jones | 7b9f5a54e8 | |
Tony Garnock-Jones | 0208ae7a7d | |
Tony Garnock-Jones | 23f269fba6 | |
Tony Garnock-Jones | 6ba9b402ec | |
Tony Garnock-Jones | 0693e88031 | |
Tony Garnock-Jones | 4a2c8147aa | |
Tony Garnock-Jones | dede7f08a7 | |
Tony Garnock-Jones | efc444ac37 | |
Tony Garnock-Jones | e54b6566f5 | |
Tony Garnock-Jones | 43e94b83b4 | |
Tony Garnock-Jones | b8e076188c | |
Tony Garnock-Jones | 00b0ef63eb | |
Tony Garnock-Jones | 1adb8110b6 | |
Tony Garnock-Jones | fd2e4cc23c | |
Tony Garnock-Jones | b24cd754b0 | |
Tony Garnock-Jones | 8f1d27c584 | |
Tony Garnock-Jones | 8546e93e5d | |
Tony Garnock-Jones | bbca582b98 | |
Tony Garnock-Jones | abc844c964 | |
Tony Garnock-Jones | 7c4e00f614 | |
Tony Garnock-Jones | 18eab695cc | |
Tony Garnock-Jones | 5d46a6e631 | |
Tony Garnock-Jones | fbece48f52 | |
Tony Garnock-Jones | 925ba8c8de | |
Tony Garnock-Jones | 1dfaf537f5 | |
Tony Garnock-Jones | 6fe897eb46 | |
Tony Garnock-Jones | 5c5da4e569 | |
Tony Garnock-Jones | 6591091bb6 | |
Tony Garnock-Jones | a428423ff2 | |
Tony Garnock-Jones | 9c5f427366 | |
Tony Garnock-Jones | 062e4603af | |
Sam Caldwell | 7b8b6c5da7 | |
Tony Garnock-Jones | 6078b81289 | |
Tony Garnock-Jones | 21a53ba948 | |
Tony Garnock-Jones | 4372df1b40 | |
Tony Garnock-Jones | 839818f8e4 | |
Tony Garnock-Jones | d033c69083 | |
Tony Garnock-Jones | 7fcfa9586b | |
Tony Garnock-Jones | 71a7bacccd | |
Tony Garnock-Jones | d149ec57ea | |
Tony Garnock-Jones | a85a941d91 | |
Tony Garnock-Jones | 7fb0c33660 | |
Tony Garnock-Jones | 8e0906d918 | |
Tony Garnock-Jones | b6ccbe81cc | |
Tony Garnock-Jones | 482afb9f62 | |
Tony Garnock-Jones | 9dee4e3b30 | |
Tony Garnock-Jones | e9b1645beb | |
Tony Garnock-Jones | 6d1dcb0993 | |
Tony Garnock-Jones | 46c35b7d98 | |
Tony Garnock-Jones | b2e0916350 | |
Tony Garnock-Jones | d05d72a629 | |
Tony Garnock-Jones | 6a71676df0 | |
Tony Garnock-Jones | a3577edb00 | |
Tony Garnock-Jones | 1830d4da6c | |
Tony Garnock-Jones | b8d9ac0d4f | |
Tony Garnock-Jones | 1e563ee1ec | |
Tony Garnock-Jones | 81d0a65fa1 | |
Tony Garnock-Jones | 545769e43c | |
Tony Garnock-Jones | 64c08ebf1c | |
Tony Garnock-Jones | 2307b1bd50 | |
Tony Garnock-Jones | d478403e7d | |
Tony Garnock-Jones | 0a4e1b2088 | |
Tony Garnock-Jones | 0d2e89e309 | |
Tony Garnock-Jones | e7c7a7cdfa | |
Tony Garnock-Jones | da978aad39 | |
Tony Garnock-Jones | 64cbe51578 | |
Tony Garnock-Jones | 761f5652af | |
Tony Garnock-Jones | a8b7de0d64 | |
Tony Garnock-Jones | b9aa833186 | |
Tony Garnock-Jones | ce0b30dba6 | |
Tony Garnock-Jones | 45d1de7358 | |
Tony Garnock-Jones | e4ae3b1f95 | |
Tony Garnock-Jones | d87118f686 | |
Tony Garnock-Jones | e7de06c2d2 | |
Tony Garnock-Jones | 3b5a07f954 | |
Tony Garnock-Jones | adaf9511bf | |
Tony Garnock-Jones | 3c124633b3 | |
Tony Garnock-Jones | dea733911d | |
Tony Garnock-Jones | 3785cebdf2 | |
Tony Garnock-Jones | fbbad85b04 | |
Tony Garnock-Jones | dc35e7c1bd | |
Tony Garnock-Jones | 21fd0f574a | |
Tony Garnock-Jones | 3c2995841e | |
Tony Garnock-Jones | 8b1d04ab05 | |
Tony Garnock-Jones | 3c3d8f2aaf | |
Tony Garnock-Jones | c84be7685f | |
Tony Garnock-Jones | dd4bd6aae8 | |
Tony Garnock-Jones | 515f8fd9a7 | |
Tony Garnock-Jones | 482852a6d6 | |
Tony Garnock-Jones | 0e4473f430 | |
Tony Garnock-Jones | a7eae9b00e | |
Tony Garnock-Jones | f675f91719 | |
Tony Garnock-Jones | e0ba76dc4e | |
Tony Garnock-Jones | fc271b6398 | |
Tony Garnock-Jones | 86d55338f1 | |
Tony Garnock-Jones | 1254083d33 | |
Tony Garnock-Jones | 1724860be2 | |
Tony Garnock-Jones | b1c773ddd4 | |
Tony Garnock-Jones | 623140dc36 | |
Leif Andersen | 6d40b1c541 | |
Tony Garnock-Jones | 0003516d9d | |
Tony Garnock-Jones | e780417355 | |
Tony Garnock-Jones | 88a5522d2f | |
Tony Garnock-Jones | e7c9bcfa8f | |
Tony Garnock-Jones | b9954c0f9e | |
Tony Garnock-Jones | 8cf886461e | |
Tony Garnock-Jones | ed2b5fed0e | |
Tony Garnock-Jones | 226e909f2a | |
Sam Caldwell | 23c482bb3e | |
Tony Garnock-Jones | 1b887a7e8e | |
Tony Garnock-Jones | c97b39f9a9 | |
Tony Garnock-Jones | ee0442b3e4 | |
Sam Caldwell | fb40c147a8 | |
Tony Garnock-Jones | 4b23320532 | |
Tony Garnock-Jones | b979dd9d70 | |
Tony Garnock-Jones | fe6e83f19e | |
Tony Garnock-Jones | f221063441 | |
Tony Garnock-Jones | 5a9e51c640 | |
Tony Garnock-Jones | 54056da195 | |
Tony Garnock-Jones | a7a23e29b4 | |
Sam Caldwell | cd490853ba | |
Sam Caldwell | 326f1e34c1 | |
Sam Caldwell | 27952df0c3 | |
Tony Garnock-Jones | 2a754624ef | |
Tony Garnock-Jones | 935fb98a1f | |
Tony Garnock-Jones | e9b431c50f | |
Tony Garnock-Jones | d29fb17ad6 | |
Tony Garnock-Jones | 4f94c8702e | |
Tony Garnock-Jones | 0e7a6375e9 | |
Tony Garnock-Jones | 49d11b1a73 | |
Tony Garnock-Jones | df0ff273b1 | |
Tony Garnock-Jones | 8c3aeec6ad | |
Tony Garnock-Jones | e02755c701 | |
Tony Garnock-Jones | 6d028f00c5 | |
Tony Garnock-Jones | afa657096a | |
Tony Garnock-Jones | 3489b5fab7 | |
Tony Garnock-Jones | a0670ec3a3 | |
Tony Garnock-Jones | 85c43510a8 | |
Tony Garnock-Jones | 5e0757b65f | |
Tony Garnock-Jones | f12f24b133 | |
Tony Garnock-Jones | 4cdd595301 | |
Tony Garnock-Jones | f06d951dcb | |
Tony Garnock-Jones | d00d205314 | |
Tony Garnock-Jones | 9d7dd37a37 | |
Tony Garnock-Jones | 8c55ada827 | |
Tony Garnock-Jones | 9a8e7b4856 | |
Tony Garnock-Jones | 674870b9ba | |
Tony Garnock-Jones | 7d1a0c58c2 | |
Tony Garnock-Jones | bfd8203a7a | |
Tony Garnock-Jones | 9f69cffbe7 | |
Tony Garnock-Jones | e0f76b991a | |
Tony Garnock-Jones | f22e228cc0 | |
Tony Garnock-Jones | d1b3ffdf81 | |
Tony Garnock-Jones | 4d87f071da | |
Tony Garnock-Jones | 6b9c7fee67 | |
Tony Garnock-Jones | bf94a2cd1c | |
Tony Garnock-Jones | 95cb196c49 | |
Tony Garnock-Jones | a0f1d61635 | |
Tony Garnock-Jones | 579b82261c | |
Tony Garnock-Jones | c2fa26f9ed | |
Tony Garnock-Jones | 1107483c86 | |
Tony Garnock-Jones | e400c1703a | |
Tony Garnock-Jones | 3476afc2ab | |
Tony Garnock-Jones | 265eee348a | |
Tony Garnock-Jones | 594add5939 | |
Tony Garnock-Jones | 8a3f50941f | |
Tony Garnock-Jones | 6c98531832 | |
Tony Garnock-Jones | 38e3c9de0f | |
Tony Garnock-Jones | a86eb10494 | |
Tony Garnock-Jones | 0db231575c | |
Tony Garnock-Jones | 0206dec737 | |
Tony Garnock-Jones | aabeb5adcd | |
Tony Garnock-Jones | 6a449648e3 | |
Tony Garnock-Jones | 54067dbeac | |
Tony Garnock-Jones | 279e273909 | |
Tony Garnock-Jones | ca5bf47adf | |
Tony Garnock-Jones | 7cb4223235 | |
Tony Garnock-Jones | 5fcb4cb777 | |
Tony Garnock-Jones | 4dfb4c46a1 | |
Tony Garnock-Jones | 1ab7475869 | |
Tony Garnock-Jones | 2fa90c59b6 | |
Tony Garnock-Jones | f3643601d4 | |
Tony Garnock-Jones | cb6f60739d | |
Tony Garnock-Jones | de35a23a6c | |
Tony Garnock-Jones | d3ca36beaf | |
Tony Garnock-Jones | dd498ab627 | |
Tony Garnock-Jones | 9f44e36688 | |
Tony Garnock-Jones | 457e1bb0e5 | |
Tony Garnock-Jones | 7b03d90b23 | |
Tony Garnock-Jones | b87f1e1da2 | |
Tony Garnock-Jones | e2dfe2fe78 | |
Tony Garnock-Jones | 543a1753ca | |
Tony Garnock-Jones | 49ea6a22b4 | |
Tony Garnock-Jones | f90ff642f1 | |
Tony Garnock-Jones | 278c54b43d | |
Tony Garnock-Jones | 5650e336d1 | |
Sam Caldwell | 6aa14d1068 | |
Tony Garnock-Jones | f9015cbf23 | |
Tony Garnock-Jones | 4429c4c120 | |
Tony Garnock-Jones | 5a4f06b350 | |
Tony Garnock-Jones | 86265bf0a0 | |
Tony Garnock-Jones | 3fef18c711 | |
Tony Garnock-Jones | c9f984a023 | |
Tony Garnock-Jones | 418a8fe0e2 | |
Tony Garnock-Jones | 6554a3deff | |
Tony Garnock-Jones | 6fe1ac6e24 | |
Tony Garnock-Jones | ba7170e7a4 | |
Tony Garnock-Jones | 287341cbbc | |
Tony Garnock-Jones | 4b81179e7a | |
Tony Garnock-Jones | 3c3dcea8ee | |
Tony Garnock-Jones | 11f2074adf | |
Tony Garnock-Jones | 72ed89ab35 | |
Tony Garnock-Jones | a3f709f63f | |
Tony Garnock-Jones | 6bb3ef493a | |
Tony Garnock-Jones | 8930b2dfbf | |
Tony Garnock-Jones | ae04b9a8fd | |
Tony Garnock-Jones | a3caad0be6 | |
Tony Garnock-Jones | a175908953 | |
Tony Garnock-Jones | db11dee3c8 | |
Tony Garnock-Jones | 69ba8d7a01 | |
Tony Garnock-Jones | 71bd34ac5b | |
Tony Garnock-Jones | 8083ddf890 | |
Tony Garnock-Jones | e28841f695 | |
Tony Garnock-Jones | 5409cebe88 | |
Tony Garnock-Jones | 8bb1b36073 | |
Tony Garnock-Jones | 9da90088b6 | |
Tony Garnock-Jones | 0ddda2aebe | |
Tony Garnock-Jones | 2420abe2e1 | |
Tony Garnock-Jones | a5db6ebc18 | |
Tony Garnock-Jones | 419bb054f1 | |
Tony Garnock-Jones | 1105a54543 | |
Tony Garnock-Jones | a6d857fe83 | |
Tony Garnock-Jones | f81d727bd9 | |
Tony Garnock-Jones | 8875fd2351 | |
Tony Garnock-Jones | c8642c2557 | |
Tony Garnock-Jones | b3f8506bf7 | |
Sam Caldwell | 83e36ed9e5 | |
Tony Garnock-Jones | 16522d8191 | |
Sam Caldwell | 3b40a8287e | |
Matthias Felleisen | 1bd0e40734 | |
Sam Caldwell | 787cf73d5f | |
Sam Caldwell | 89cff7adc8 | |
Sam Caldwell | e2ffe9bef6 | |
Tony Garnock-Jones | 543073fd2e | |
Tony Garnock-Jones | e6530e2e4a | |
Tony Garnock-Jones | 0072607f65 | |
Tony Garnock-Jones | 112c33302e | |
Tony Garnock-Jones | c7ae3c64d3 | |
Tony Garnock-Jones | 14bd1f282d | |
Tony Garnock-Jones | 6bd6eecf0e | |
Tony Garnock-Jones | 7f06f3ceee | |
Tony Garnock-Jones | b94e6113b0 | |
Tony Garnock-Jones | 63039b63f0 | |
Tony Garnock-Jones | 4c6dd497c1 | |
Tony Garnock-Jones | 32d8922b28 | |
Tony Garnock-Jones | 974c8a5807 | |
Tony Garnock-Jones | 0a5abb8fff | |
Tony Garnock-Jones | 4451795146 | |
Tony Garnock-Jones | b98e0bedb8 | |
Tony Garnock-Jones | 50fc02f899 | |
Tony Garnock-Jones | 7456e2efec | |
Tony Garnock-Jones | c4b14b3331 | |
Tony Garnock-Jones | cee6f9158b | |
Tony Garnock-Jones | 2be8b26ff0 | |
Tony Garnock-Jones | 887c6d9990 | |
Tony Garnock-Jones | 0bf2033d44 | |
Tony Garnock-Jones | 89acb53a43 | |
Tony Garnock-Jones | e913237f26 | |
Tony Garnock-Jones | 9f9431cb29 | |
Tony Garnock-Jones | 034a96bcc9 | |
Tony Garnock-Jones | b497004f0b | |
Tony Garnock-Jones | 6a3bafe082 | |
Tony Garnock-Jones | 82c5ea71ed | |
Tony Garnock-Jones | ea9660d83d | |
Tony Garnock-Jones | 93b1b0fcf3 | |
Tony Garnock-Jones | 33a60e4a02 | |
Tony Garnock-Jones | 191a71ec80 | |
Tony Garnock-Jones | ae9887b8fb | |
Tony Garnock-Jones | 90c8e8555b | |
Tony Garnock-Jones | d063b3b2fb | |
Tony Garnock-Jones | 39b19ba624 | |
Tony Garnock-Jones | 61c59250ee | |
Tony Garnock-Jones | 1fb6935d81 | |
Tony Garnock-Jones | f5ce8cd93f | |
Tony Garnock-Jones | 42850e20ef | |
Tony Garnock-Jones | a2eeb6d5e4 | |
Tony Garnock-Jones | e76fa1527c | |
Tony Garnock-Jones | 25c970902d | |
Tony Garnock-Jones | 3130b307b5 | |
Tony Garnock-Jones | 03a6455594 | |
Tony Garnock-Jones | 4de4180c67 | |
Tony Garnock-Jones | ccc5775f00 | |
Tony Garnock-Jones | c5530c7b9c | |
Tony Garnock-Jones | ad56852b5b | |
Tony Garnock-Jones | 0d11381954 | |
Tony Garnock-Jones | 7f5fa1d7c8 | |
Tony Garnock-Jones | 7f18a83606 | |
Tony Garnock-Jones | ed6f535266 | |
Tony Garnock-Jones | 630d0e29bd | |
Tony Garnock-Jones | 57e22a5d3c | |
Tony Garnock-Jones | b5e73b8462 | |
Tony Garnock-Jones | 97009ad9a7 |
|
@ -0,0 +1,165 @@
|
|||
GNU LESSER GENERAL PUBLIC LICENSE
|
||||
Version 3, 29 June 2007
|
||||
|
||||
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
|
||||
Everyone is permitted to copy and distribute verbatim copies
|
||||
of this license document, but changing it is not allowed.
|
||||
|
||||
|
||||
This version of the GNU Lesser General Public License incorporates
|
||||
the terms and conditions of version 3 of the GNU General Public
|
||||
License, supplemented by the additional permissions listed below.
|
||||
|
||||
0. Additional Definitions.
|
||||
|
||||
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||
General Public License.
|
||||
|
||||
"The Library" refers to a covered work governed by this License,
|
||||
other than an Application or a Combined Work as defined below.
|
||||
|
||||
An "Application" is any work that makes use of an interface provided
|
||||
by the Library, but which is not otherwise based on the Library.
|
||||
Defining a subclass of a class defined by the Library is deemed a mode
|
||||
of using an interface provided by the Library.
|
||||
|
||||
A "Combined Work" is a work produced by combining or linking an
|
||||
Application with the Library. The particular version of the Library
|
||||
with which the Combined Work was made is also called the "Linked
|
||||
Version".
|
||||
|
||||
The "Minimal Corresponding Source" for a Combined Work means the
|
||||
Corresponding Source for the Combined Work, excluding any source code
|
||||
for portions of the Combined Work that, considered in isolation, are
|
||||
based on the Application, and not on the Linked Version.
|
||||
|
||||
The "Corresponding Application Code" for a Combined Work means the
|
||||
object code and/or source code for the Application, including any data
|
||||
and utility programs needed for reproducing the Combined Work from the
|
||||
Application, but excluding the System Libraries of the Combined Work.
|
||||
|
||||
1. Exception to Section 3 of the GNU GPL.
|
||||
|
||||
You may convey a covered work under sections 3 and 4 of this License
|
||||
without being bound by section 3 of the GNU GPL.
|
||||
|
||||
2. Conveying Modified Versions.
|
||||
|
||||
If you modify a copy of the Library, and, in your modifications, a
|
||||
facility refers to a function or data to be supplied by an Application
|
||||
that uses the facility (other than as an argument passed when the
|
||||
facility is invoked), then you may convey a copy of the modified
|
||||
version:
|
||||
|
||||
a) under this License, provided that you make a good faith effort to
|
||||
ensure that, in the event an Application does not supply the
|
||||
function or data, the facility still operates, and performs
|
||||
whatever part of its purpose remains meaningful, or
|
||||
|
||||
b) under the GNU GPL, with none of the additional permissions of
|
||||
this License applicable to that copy.
|
||||
|
||||
3. Object Code Incorporating Material from Library Header Files.
|
||||
|
||||
The object code form of an Application may incorporate material from
|
||||
a header file that is part of the Library. You may convey such object
|
||||
code under terms of your choice, provided that, if the incorporated
|
||||
material is not limited to numerical parameters, data structure
|
||||
layouts and accessors, or small macros, inline functions and templates
|
||||
(ten or fewer lines in length), you do both of the following:
|
||||
|
||||
a) Give prominent notice with each copy of the object code that the
|
||||
Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
4. Combined Works.
|
||||
|
||||
You may convey a Combined Work under terms of your choice that,
|
||||
taken together, effectively do not restrict modification of the
|
||||
portions of the Library contained in the Combined Work and reverse
|
||||
engineering for debugging such modifications, if you also do each of
|
||||
the following:
|
||||
|
||||
a) Give prominent notice with each copy of the Combined Work that
|
||||
the Library is used in it and that the Library and its use are
|
||||
covered by this License.
|
||||
|
||||
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||
document.
|
||||
|
||||
c) For a Combined Work that displays copyright notices during
|
||||
execution, include the copyright notice for the Library among
|
||||
these notices, as well as a reference directing the user to the
|
||||
copies of the GNU GPL and this license document.
|
||||
|
||||
d) Do one of the following:
|
||||
|
||||
0) Convey the Minimal Corresponding Source under the terms of this
|
||||
License, and the Corresponding Application Code in a form
|
||||
suitable for, and under terms that permit, the user to
|
||||
recombine or relink the Application with a modified version of
|
||||
the Linked Version to produce a modified Combined Work, in the
|
||||
manner specified by section 6 of the GNU GPL for conveying
|
||||
Corresponding Source.
|
||||
|
||||
1) Use a suitable shared library mechanism for linking with the
|
||||
Library. A suitable mechanism is one that (a) uses at run time
|
||||
a copy of the Library already present on the user's computer
|
||||
system, and (b) will operate properly with a modified version
|
||||
of the Library that is interface-compatible with the Linked
|
||||
Version.
|
||||
|
||||
e) Provide Installation Information, but only if you would otherwise
|
||||
be required to provide such information under section 6 of the
|
||||
GNU GPL, and only to the extent that such information is
|
||||
necessary to install and execute a modified version of the
|
||||
Combined Work produced by recombining or relinking the
|
||||
Application with a modified version of the Linked Version. (If
|
||||
you use option 4d0, the Installation Information must accompany
|
||||
the Minimal Corresponding Source and Corresponding Application
|
||||
Code. If you use option 4d1, you must provide the Installation
|
||||
Information in the manner specified by section 6 of the GNU GPL
|
||||
for conveying Corresponding Source.)
|
||||
|
||||
5. Combined Libraries.
|
||||
|
||||
You may place library facilities that are a work based on the
|
||||
Library side by side in a single library together with other library
|
||||
facilities that are not Applications and are not covered by this
|
||||
License, and convey such a combined library under terms of your
|
||||
choice, if you do both of the following:
|
||||
|
||||
a) Accompany the combined library with a copy of the same work based
|
||||
on the Library, uncombined with any other library facilities,
|
||||
conveyed under the terms of this License.
|
||||
|
||||
b) Give prominent notice with the combined library that part of it
|
||||
is a work based on the Library, and explaining where to find the
|
||||
accompanying uncombined form of the same work.
|
||||
|
||||
6. Revised Versions of the GNU Lesser General Public License.
|
||||
|
||||
The Free Software Foundation may publish revised and/or new versions
|
||||
of the GNU Lesser General Public License from time to time. Such new
|
||||
versions will be similar in spirit to the present version, but may
|
||||
differ in detail to address new problems or concerns.
|
||||
|
||||
Each version is given a distinguishing version number. If the
|
||||
Library as you received it specifies that a certain numbered version
|
||||
of the GNU Lesser General Public License "or any later version"
|
||||
applies to it, you have the option of following the terms and
|
||||
conditions either of that published version or of any later version
|
||||
published by the Free Software Foundation. If the Library as you
|
||||
received it does not specify a version number of the GNU Lesser
|
||||
General Public License, you may choose any version of the GNU Lesser
|
||||
General Public License ever published by the Free Software Foundation.
|
||||
|
||||
If the Library as you received it specifies that a proxy can decide
|
||||
whether future versions of the GNU Lesser General Public License shall
|
||||
apply, that proxy's public statement of acceptance of any version is
|
||||
permanent authorization for you to choose that version for the
|
||||
Library.
|
61
README.md
61
README.md
|
@ -1,6 +1,6 @@
|
|||
# Prospect: A Networked, Concurrent, Functional Programming Language
|
||||
# Syndicate: A Networked, Concurrent, Functional Programming Language
|
||||
|
||||
Prospect is an actor-based concurrent language able to express
|
||||
Syndicate is an actor-based concurrent language able to express
|
||||
communication, enforce isolation, and manage resources.
|
||||
Network-inspired extensions to a functional core represent imperative
|
||||
actions as values, giving side-effects locality and enabling
|
||||
|
@ -11,7 +11,7 @@ virtual machines) to scope their interactions. Conversations between
|
|||
actors are multi-party (using a publish/subscribe medium), and actors
|
||||
can easily participate in many such conversations at once.
|
||||
|
||||
Prospect makes *presence* notifications an integral part of pub/sub
|
||||
Syndicate makes *presence* notifications an integral part of pub/sub
|
||||
through its *shared dataspaces*, akin to
|
||||
[tuplespaces](https://en.wikipedia.org/wiki/Tuple_space). Each shared
|
||||
dataspace doubles as the pub/sub subscription table for its network.
|
||||
|
@ -24,43 +24,42 @@ networks-within-networks. Programs can give up responsibility for
|
|||
maintaining shared state and for scoping group communications, letting
|
||||
their containing network take on those burdens.
|
||||
|
||||
## The code
|
||||
## Contents
|
||||
|
||||
This repository contains a [Racket](http://racket-lang.org/) package,
|
||||
`prospect`, which includes
|
||||
This repository contains
|
||||
|
||||
- the implementation of the `#lang prospect` language, in the
|
||||
[`prospect` directory](https://github.com/tonyg/prospect/tree/master/prospect/).
|
||||
- a [Racket](http://racket-lang.org/) implementation of Syndicate
|
||||
(plus auxiliary modules) in `racket/syndicate/`
|
||||
|
||||
- a TCP echo server example, which listens for connections on port
|
||||
5999 by default, in
|
||||
[`prospect/examples/echo.rkt`](https://github.com/tonyg/prospect/tree/master/prospect/examples/echo.rkt).
|
||||
Connect to it using, for example, `telnet localhost 5999`.
|
||||
- an
|
||||
[ECMAScript 5](http://www.ecma-international.org/publications/standards/Ecma-262.htm)
|
||||
implementation of Syndicate in `js/`
|
||||
|
||||
- a handful of other examples, in
|
||||
[`prospect/examples/`](https://github.com/tonyg/prospect/tree/master/prospect/examples/).
|
||||
- larger example programs:
|
||||
|
||||
## Compiling and running the code
|
||||
- `examples/platformer`, a 2D Platform game written in Syndicate
|
||||
for Racket.
|
||||
|
||||
You will need Racket version 6.2.x or later.
|
||||
- `examples/netstack`, a TCP/IP stack written in Syndicate for
|
||||
Racket. It reads and writes raw Ethernet packets from the kernel
|
||||
using Linux- and OSX-specific APIs.
|
||||
|
||||
Once you have Racket installed, run
|
||||
- a sketch of a Haskell implementation of the core routing structures
|
||||
of Syndicate in `hs/`
|
||||
|
||||
raco pkg install prospect
|
||||
## Copyright and License
|
||||
|
||||
to install the package from the Racket package repository, or
|
||||
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018.
|
||||
|
||||
raco pkg install
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU Lesser General Public License as published by
|
||||
the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
from the root directory of the Git checkout to install the package
|
||||
from a local snapshot. (Alternatively, `make link` does the same thing.)
|
||||
This will make `#lang prospect` available to programs.
|
||||
This program 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 Lesser General Public License for more details.
|
||||
|
||||
At this point, you may load and run any of the example `*.rkt` files
|
||||
in the
|
||||
[`prospect/examples/`](https://github.com/tonyg/prospect/tree/master/prospect/examples/)
|
||||
directory.
|
||||
|
||||
## Copyright
|
||||
|
||||
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014, 2015, 2016.
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
|
|
@ -1,51 +0,0 @@
|
|||
#lang racket ;; -*- racket -*-
|
||||
|
||||
(require "../main.rkt")
|
||||
(require "../big-bang.rkt")
|
||||
|
||||
(define (button #:background [background "grey"]
|
||||
#:foreground [foreground "white"]
|
||||
#:font-size [font-size 22]
|
||||
name x y label callback)
|
||||
(define label-image (text label font-size foreground))
|
||||
(actor (forever
|
||||
(on (message (at-meta (mouse-event ? ? name "button-down"))) (callback))
|
||||
(assert (window name x y 0
|
||||
(seal
|
||||
(overlay label-image
|
||||
(rectangle (+ (image-width label-image) 20)
|
||||
(+ (image-height label-image) 20)
|
||||
"solid"
|
||||
background))))))))
|
||||
|
||||
(define (draggable-shape name orig-x orig-y image)
|
||||
(define (move-to x y) (assert (update-window name x y image #:z 10)))
|
||||
(define (idle ticks x y)
|
||||
(state [#:collect [(ticks ticks) (x x) (y y)]
|
||||
(move-to x y)
|
||||
(on (message (at-meta (tick-event)))
|
||||
(define new-ticks (+ ticks 1))
|
||||
(define displacement (* (cos (* new-ticks 10 1/180 pi)) 4))
|
||||
(values new-ticks x (+ y displacement)))]
|
||||
[(message (at-meta (mouse-event mx my name "button-down")))
|
||||
(dragging mx my (- mx x) (- my y))]))
|
||||
(define (dragging mx my dx dy)
|
||||
(state [#:collect [(mx mx) (my my)]
|
||||
(move-to (- mx dx) (- my dy))
|
||||
(on (message (at-meta (mouse-event mx my ? "drag"))) (values mx my))]
|
||||
[(message (at-meta (mouse-event mx my ? (or "leave" "button-up"))))
|
||||
(idle 0 (- mx dx) (- my dy))]))
|
||||
(actor (idle 0 orig-x orig-y)))
|
||||
|
||||
(big-bang-network #:width 640
|
||||
#:height 480
|
||||
(actor (forever
|
||||
(on (asserted (active-window $id) #:meta-level 1)
|
||||
(update-window 'active-window-label 300 0
|
||||
(text (format "~v" id) 22 "black")))))
|
||||
(button #:background "red" 'stop-button 0 0 "Exit"
|
||||
(lambda () (assert! 'stop #:meta-level 1)))
|
||||
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
|
||||
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")))
|
||||
|
||||
(exit 0)
|
|
@ -1,22 +0,0 @@
|
|||
#lang prospect ;; -*- racket -*-
|
||||
|
||||
(require (only-in racket/port read-bytes-line-evt))
|
||||
(require "../drivers/tcp.rkt")
|
||||
|
||||
(define local-handle (tcp-handle 'chat))
|
||||
(define remote-handle (tcp-address "localhost" 5999))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
(actor (define e (read-bytes-line-evt (current-input-port) 'any))
|
||||
(until (rising-edge quit?)
|
||||
#:collect [quit? #f]
|
||||
(assert (advertise (tcp-channel local-handle remote-handle ?)))
|
||||
(on (retracted (advertise (tcp-channel remote-handle local-handle ?))) #t)
|
||||
(on (message (at-meta (external-event e (list $value))))
|
||||
(match value
|
||||
[(? eof-object?) #t]
|
||||
[(? bytes?) (send! (tcp-channel local-handle remote-handle value)) #f]))
|
||||
(on (message (tcp-channel remote-handle local-handle $bs))
|
||||
(write-bytes bs)
|
||||
(flush-output)
|
||||
#f)))
|
|
@ -1,31 +0,0 @@
|
|||
#lang prospect ;; -*- racket -*-
|
||||
|
||||
(require (only-in racket/string string-trim))
|
||||
(require "../drivers/tcp.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
|
||||
(define (spawn-session them us)
|
||||
(define user (gensym 'user))
|
||||
(define (send-to-remote fmt . vs)
|
||||
(send! (at-meta (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
|
||||
(define (say who fmt . vs)
|
||||
(unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
(actor (send-to-remote "Welcome, ~a.\n" user)
|
||||
(until (retracted (advertise (tcp-channel them us ?)) #:meta-level 1)
|
||||
(assert (advertise (tcp-channel us them ?) #:meta-level 1))
|
||||
(assert (advertise `(,user says ,?)))
|
||||
(on (asserted (advertise `(,$who says ,?))) (say who "arrived."))
|
||||
(on (retracted (advertise `(,$who says ,?))) (say who "departed."))
|
||||
(on `(,$who says ,$what) (say who "says: ~a" what))
|
||||
(on (message (at-meta (tcp-channel them us $bs)))
|
||||
(define input-string (string-trim (bytes->string/utf-8 bs)))
|
||||
(if (equal? input-string "quit-network")
|
||||
(assert! 'quit-network)
|
||||
(send! `(,user says ,input-string)))))
|
||||
(send-to-remote "Goodbye!\n")))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
(let ((us (tcp-listener 5999)))
|
||||
(group (until (asserted 'quit-network)
|
||||
(on (asserted (advertise (tcp-channel $them us ?)) #:meta-level 1)
|
||||
(spawn-session them us)))))
|
|
@ -0,0 +1,57 @@
|
|||
digraph G {
|
||||
node[shape=box];
|
||||
|
||||
// s0000 idle
|
||||
// s1000 error
|
||||
// s0100 supply
|
||||
// s1100 running
|
||||
// s1010 starting
|
||||
// s0011 starting_unwanted
|
||||
// s1011 starting_doomed
|
||||
// s0101 unwanted
|
||||
// s1101 running_doomed
|
||||
|
||||
idle -> starting [label="D+/start"];
|
||||
supply -> starting [label="D+,S-/start"];
|
||||
error -> idle [label="D-"];
|
||||
error -> running [label="S+"];
|
||||
error -> unwanted [label="D-,S+"];
|
||||
running -> unwanted [label="D-"];
|
||||
running -> error [label="S-/error"];
|
||||
|
||||
unwanted -> idle [label="S-"];
|
||||
unwanted -> starting [label="D+,S-/start"];
|
||||
running_doomed -> starting [label="S-/start"];
|
||||
running_doomed -> idle [label="D-,S-"];
|
||||
|
||||
starting -> starting_unwanted [label="D-"];
|
||||
starting -> running [label="S+"];
|
||||
starting -> unwanted [label="D-,S+"];
|
||||
starting_unwanted -> unwanted [label="S+"];
|
||||
starting_unwanted -> running_doomed [label="D+,S+"];
|
||||
starting_doomed -> running_doomed [label="S+"];
|
||||
starting_doomed -> unwanted [label="D-,S+"];
|
||||
|
||||
|
||||
idle -> supply [label="S+"];
|
||||
idle -> running [label="D+S+"];
|
||||
supply -> running [label="D+"];
|
||||
supply -> idle [label="S-"];
|
||||
running -> idle [label="D-,S-"];
|
||||
unwanted -> running_doomed [label="D+"];
|
||||
running_doomed -> unwanted [label="D-"];
|
||||
starting_unwanted -> starting_doomed [label="D+"];
|
||||
starting_doomed -> starting_unwanted [label="D-"];
|
||||
|
||||
|
||||
// s0001 -> impossible [label="any"];
|
||||
// s0010 -> impossible [label="any"];
|
||||
|
||||
// s1001 -> impossible [label="any"];
|
||||
|
||||
// s0110 -> impossible [label="any"];
|
||||
// s1110 -> impossible [label="any"];
|
||||
// s0111 -> impossible [label="any"];
|
||||
// s1111 -> impossible [label="any"];
|
||||
|
||||
}
|
|
@ -0,0 +1,388 @@
|
|||
# Demand-matching and Supervision
|
||||
|
||||
The Demand Matcher pattern (in `demand-matcher.rkt` and in
|
||||
`demand-matcher.js`'s `DemandMatcher` class) tracks assertions
|
||||
representing some abstract *demand* for a resource, and causes the
|
||||
creation or acquisition of matching *supply* of that resource.
|
||||
|
||||
To do this, it tracks the state of each *instance* of the resource.
|
||||
Each resource instance (called a "task") is uniquely identified by a
|
||||
projection of the dataspace.
|
||||
|
||||
The basic idea is that:
|
||||
|
||||
- When demand for a task is detected, it is started.
|
||||
|
||||
- Each started task signals its presence to the DemandMatcher.
|
||||
|
||||
- When demand drops, the task should detect this and exit.
|
||||
|
||||
- If the task exits unexpectedly, this is an error, and the
|
||||
DemandMatcher prints a warning.
|
||||
|
||||
## Latency causes problems
|
||||
|
||||
However, because there can be some latency between requesting the
|
||||
start of a task and its signalling its presence to the DemandMatcher,
|
||||
we can't just figure out what to do based on the presence or absence
|
||||
of demand and supply for a task. We also need to track a few more bits
|
||||
of information.
|
||||
|
||||
When demand for a task drops briefly, we expect a drop in supply in
|
||||
future, *even if demand increases again before we detect a supply
|
||||
drop*.
|
||||
|
||||
For this reason, in some circumstances, the default task supervision
|
||||
strategy of DemandMatcher *recreates* supply on supply drop in some
|
||||
circumstances. It keeps track of whether a supply increase is
|
||||
expected, and of whether a supply decrease is expected for each task.
|
||||
|
||||
It becomes an important part of the DemandMatcher protocol for a task
|
||||
instance to always drop its supply assertion in response to a drop in
|
||||
demand. This works well in Syndicate implementations that preserve all
|
||||
assertion transitions, but not at all well where brief transitions may
|
||||
be elided. In those cases, we will have to reach for a more heuristic
|
||||
approach involving something akin to Erlang's "Maximum Restart
|
||||
Intensity" and/or other kinds of time-based decision. For now though,
|
||||
the precise case works fine.
|
||||
|
||||
While it seems simple enough to imagine, the details are rather
|
||||
fiddly.
|
||||
|
||||
## Working out the algorithm that defaultTaskSupervisor should use
|
||||
|
||||
We may assume some expected task behaviour: that it will eventually
|
||||
assert supply, and *then* upon demand drop eventually exit.
|
||||
|
||||
◇(supply ∧ (¬demand ⇒ ◇ terminate)) (?!?!)
|
||||
|
||||
### Complete table of actions
|
||||
|
||||
Each row in this table describes actions taken in a particular
|
||||
circumstance by `defaultTaskSupervisor`.
|
||||
|
||||
The table has seven columns:
|
||||
- `∃D`, whether demand for the task exists currently
|
||||
- `∃S`, whether supply for the task exists currently
|
||||
- `ΔD`, whether (and in which direction) demand is changing now
|
||||
- `ΔS`, whether (and in which direction) supply is changing now
|
||||
- `expS+`, whether we expect a supply increase at some point in future
|
||||
- `expS-`, whether we expect a supply decrease at some point in future
|
||||
- and an action to take in this circumstance.
|
||||
|
||||
The first two values are drawn from the state of the DemandMatcher;
|
||||
the second two, from the patch event the DemandMatcher is currently
|
||||
processing; and the third two are private state variables of the task
|
||||
supervisor itself.
|
||||
|
||||
∃D ∃S ΔD ΔS expS+ expS- Action
|
||||
---------------------------------------------------------------------------
|
||||
- - + - - Start task, set expS+
|
||||
- - + - - No action (but slightly weird)
|
||||
- - + + - - No action (but slightly weird)
|
||||
- Y + - - No action (pre-extant supply)
|
||||
- Y - - - No action
|
||||
- Y + - - - Start task, set expS+
|
||||
Y - - - - Demand goes after unexpected supply drop
|
||||
Y - + - - Spontaneous recovery from unexpected supply drop
|
||||
Y - - + - - Spontaneous recovery from unexpected supply drop; set expS-
|
||||
Y Y - - - Set expS-
|
||||
Y Y - - - Unexpected supply drop error
|
||||
Y Y - - - - No action (but slightly weird)
|
||||
|
||||
- - + - Y Impossible (expS- would be clear or expS+ set)
|
||||
- - + - Y Impossible (expS- would be clear or expS+ set)
|
||||
- - + + - Y Impossible (expS- would be clear or expS+ set)
|
||||
- Y + - Y No action
|
||||
- Y - - Y Clear expS-
|
||||
- Y + - - Y Clear expS-, start task, set expS+
|
||||
Y - - - Y Impossible (expS+ would be set)
|
||||
Y - + - Y Impossible (expS+ would be set)
|
||||
Y - - + - Y Impossible (expS+ would be set)
|
||||
Y Y - - Y No action
|
||||
Y Y - - Y Clear expS-, start task, set expS+
|
||||
Y Y - - - Y Clear expS-
|
||||
|
||||
- - + Y - Impossible (expS+ would be clear or expS- set)
|
||||
- - + Y - Impossible (expS+ would be clear or expS- set)
|
||||
- - + + Y - Impossible (expS+ would be clear or expS- set)
|
||||
- Y + Y - Impossible (expS+ would be clear)
|
||||
- Y - Y - Impossible (expS+ would be clear)
|
||||
- Y + - Y - Impossible (expS+ would be clear)
|
||||
Y - - Y - Set expS-
|
||||
Y - + Y - Clear expS+
|
||||
Y - - + Y - Clear expS+, set expS-
|
||||
Y Y - Y - Impossible (expS+ would be clear)
|
||||
Y Y - Y - Impossible (expS+ would be clear)
|
||||
Y Y - - Y - Impossible (expS+ would be clear)
|
||||
|
||||
- - + Y Y No action
|
||||
- - + Y Y Clear expS+
|
||||
- - + + Y Y Clear expS+
|
||||
- Y + Y Y Impossible (expS+ would be clear)
|
||||
- Y - Y Y Impossible (expS+ would be clear)
|
||||
- Y + - Y Y Impossible (expS+ would be clear)
|
||||
Y - - Y Y No action
|
||||
Y - + Y Y Clear expS+
|
||||
Y - - + Y Y Clear expS+
|
||||
Y Y - Y Y Impossible (expS+ would be clear)
|
||||
Y Y - Y Y Impossible (expS+ would be clear)
|
||||
Y Y - - Y Y Impossible (expS+ would be clear)
|
||||
|
||||
#### Actions and transitions involving actions
|
||||
|
||||
From the table, we learn that the possible actions are:
|
||||
|
||||
- `START`, Start task, set expS+
|
||||
- `EXPDROP`, Set expS-
|
||||
- `GOTDROP`, Clear expS-
|
||||
- `RUNNING`, Clear expS+
|
||||
|
||||
There are also a couple of pseudo-actions, `ERROR` for an unexpected
|
||||
supply drop, and `RECOVER` for circumstances marking spontaneous
|
||||
recovery after an unexpected supply drop.
|
||||
|
||||
The final four columns in this table are the new states of the
|
||||
DemandMatcher and the task supervisor.
|
||||
|
||||
∃D ∃S ΔD ΔS expS+ expS- Actions Next: ∃D ∃S expS+ expS-
|
||||
---------------------------------------------------------------------------
|
||||
- - + - - START Y - Y -
|
||||
- Y + - - - START Y - Y -
|
||||
Y - - - - RECOVERY - - - -
|
||||
Y - + - - RECOVER Y Y - -
|
||||
Y - - + - - RECOVER EXPDROP - Y - Y
|
||||
Y Y - - - EXPDROP - Y - Y
|
||||
Y Y - - - ERROR Y - - -
|
||||
|
||||
- Y - - Y GOTDROP - - - -
|
||||
- Y + - - Y GOTDROP START Y - Y -
|
||||
Y Y - - Y GOTDROP START Y - Y -
|
||||
Y Y - - - Y GOTDROP - - - -
|
||||
|
||||
Y - - Y - EXPDROP - - Y Y
|
||||
Y - + Y - RUNNING Y Y - -
|
||||
Y - - + Y - RUNNING EXPDROP - Y - Y
|
||||
|
||||
- - + Y Y RUNNING - Y - Y
|
||||
- - + + Y Y RUNNING Y Y - Y
|
||||
Y - + Y Y RUNNING Y Y - Y
|
||||
Y - - + Y Y RUNNING - Y - Y
|
||||
|
||||
#### Impossible states
|
||||
|
||||
Some states are impossible to reach.
|
||||
|
||||
It is impossible for neither supply nor demand to exist, when either
|
||||
but not both of a rise or a drop in supply is expected:
|
||||
|
||||
∃D ∃S ΔD ΔS expS+ expS-
|
||||
---------------------------------------------------------------------------
|
||||
- - - Y Impossible (expS- would be clear or expS+ set)
|
||||
- - Y - Impossible (expS+ would be clear or expS- set)
|
||||
|
||||
It is impossible for demand but no supply to exist, when a drop in
|
||||
supply is expected but no rise in supply is expected:
|
||||
|
||||
∃D ∃S ΔD ΔS expS+ expS-
|
||||
---------------------------------------------------------------------------
|
||||
Y - - Y Impossible (expS+ would be set)
|
||||
|
||||
It is impossible for supply to exist while a rise in supply is
|
||||
expected:
|
||||
|
||||
∃D ∃S ΔD ΔS expS+ expS-
|
||||
---------------------------------------------------------------------------
|
||||
- Y Y - Impossible (expS+ would be clear)
|
||||
Y Y Y - Impossible (expS+ would be clear)
|
||||
- Y Y Y Impossible (expS+ would be clear)
|
||||
Y Y Y Y Impossible (expS+ would be clear)
|
||||
|
||||
#### Transitions involving only DemandMatcher state change
|
||||
|
||||
Where no task supervisor state changes and no actions are needed:
|
||||
|
||||
∃D ∃S ΔD ΔS expS+ expS- Actions Next: ∃D ∃S expS+ expS-
|
||||
---------------------------------------------------------------------------
|
||||
- - + - - - Y - -
|
||||
- - + + - - Y Y - -
|
||||
- Y + - - Y Y - -
|
||||
- Y - - - - - - -
|
||||
Y Y - - - - - - - -
|
||||
- Y + - Y Y Y - Y
|
||||
Y Y - - Y - Y - Y
|
||||
- - + Y Y Y - Y Y
|
||||
Y - - Y Y - - Y Y
|
||||
|
||||
### Transition diagram
|
||||
|
||||
![DemandMatcher task supervisor transition diagram](demand-matcher.png)
|
||||
|
||||
### From state machine to implementation
|
||||
|
||||
We can give the reachable states reasonable names:
|
||||
|
||||
∃D ∃S expS+ expS- Name
|
||||
---------------------------------------
|
||||
- - - - IDLE
|
||||
Y - Y - STARTING
|
||||
Y Y - - RUNNING
|
||||
- Y - Y UNWANTED
|
||||
|
||||
Y - Y Y STARTING_DOOMED
|
||||
- - Y Y STARTING_UNWANTED
|
||||
Y Y - Y RUNNING_DOOMED
|
||||
|
||||
- Y - - SUPPLY
|
||||
Y - - - ERROR
|
||||
|
||||
However, writing out the full state machine in terms of these states
|
||||
doesn't exploit all the redundancy in the machine.
|
||||
|
||||
Instead, let's group transitions by their effects on the task
|
||||
supervisor's state, the "expected" bits. There are only four possible
|
||||
actions (excluding warnings related to recovery etc.):
|
||||
|
||||
START - set expS+ (and start a task instance)
|
||||
RUNNING - clear expS+
|
||||
EXPDROP - set expS-
|
||||
GOTDROP - clear expS-
|
||||
|
||||
---------------------------------------------------------------------------
|
||||
|
||||
Leave expS+ alone, set expS-:
|
||||
|
||||
Y - - + - - EXPDROP - Y - Y
|
||||
Y Y - - - EXPDROP - Y - Y
|
||||
Y - - Y - EXPDROP - - Y Y
|
||||
|
||||
Leave expS+ alone, clear expS-:
|
||||
|
||||
- Y - - Y GOTDROP - - - -
|
||||
Y Y - - - Y GOTDROP - - - -
|
||||
|
||||
Set expS+, leave expS- alone:
|
||||
|
||||
- - + - - START Y - Y -
|
||||
- Y + - - - START Y - Y -
|
||||
|
||||
Set expS+, clear expS-:
|
||||
|
||||
- Y + - - Y START GOTDROP Y - Y -
|
||||
Y Y - - Y START GOTDROP Y - Y -
|
||||
|
||||
Clear expS+, leave expS- alone:
|
||||
|
||||
Y - + Y - RUNNING Y Y - -
|
||||
- - + Y Y RUNNING - Y - Y
|
||||
- - + + Y Y RUNNING Y Y - Y
|
||||
Y - + Y Y RUNNING Y Y - Y
|
||||
Y - - + Y Y RUNNING - Y - Y
|
||||
|
||||
Clear expS+, set expS-:
|
||||
|
||||
Y - - + Y - RUNNING EXPDROP - Y - Y
|
||||
|
||||
---------------------------------------------------------------------------
|
||||
|
||||
Now, let's look at those grouped by specific action (some rows will
|
||||
appear twice, because some rows involve more than one action):
|
||||
|
||||
Expdrop:
|
||||
|
||||
Y - - + - - EXPDROP - Y - Y
|
||||
Y Y - - - EXPDROP - Y - Y
|
||||
Y - - Y - EXPDROP - - Y Y
|
||||
Y - - + Y - RUNNING EXPDROP - Y - Y
|
||||
|
||||
- "Set expS- whenever a drop in demand is detected, and either (a)
|
||||
increase in supply is detected, (b) supply exists and is not
|
||||
falling, or (c) supply is expected to exist."
|
||||
|
||||
Gotdrop:
|
||||
|
||||
- Y - - Y GOTDROP - - - -
|
||||
Y Y - - - Y GOTDROP - - - -
|
||||
- Y + - - Y START GOTDROP Y - Y -
|
||||
Y Y - - Y START GOTDROP Y - Y -
|
||||
|
||||
- "Clear expS- whenever a drop in supply is detected."
|
||||
|
||||
Start:
|
||||
|
||||
- - + - - START Y - Y -
|
||||
- Y + - - - START Y - Y -
|
||||
- Y + - - Y START GOTDROP Y - Y -
|
||||
Y Y - - Y START GOTDROP Y - Y -
|
||||
|
||||
- "Set expS+ and start a task whenever expS+ is clear and demand
|
||||
becomes or remains high and supply becomes or remains low UNLESS
|
||||
demand is already high, supply drops, and expS- is clear, which is
|
||||
the 'unexpected drop' error case."
|
||||
|
||||
Running:
|
||||
|
||||
Y - + Y - RUNNING Y Y - -
|
||||
- - + Y Y RUNNING - Y - Y
|
||||
- - + + Y Y RUNNING Y Y - Y
|
||||
Y - + Y Y RUNNING Y Y - Y
|
||||
Y - - + Y Y RUNNING - Y - Y
|
||||
Y - - + Y - RUNNING EXPDROP - Y - Y
|
||||
|
||||
- "Clear expS+ whenever supply increases."
|
||||
|
||||
---------------------------------------------------------------------------
|
||||
|
||||
Now let's take those rules and check them against the full rulebase:
|
||||
|
||||
"Set expS- whenever a drop in demand is detected, and either (a)
|
||||
increase in supply is detected, (b) supply exists and is not
|
||||
falling, or (c) supply is expected to exist."
|
||||
|
||||
Y - - + - - RECOVER EXPDROP - Y - Y
|
||||
Y Y - - - EXPDROP - Y - Y
|
||||
Y - - Y - EXPDROP - - Y Y
|
||||
Y - - + Y - RUNNING EXPDROP - Y - Y
|
||||
Y - - + Y Y RUNNING - Y - Y
|
||||
Y Y - - Y - Y - Y
|
||||
Y - - Y Y - - Y Y
|
||||
|
||||
"Clear expS- whenever a drop in supply is detected."
|
||||
|
||||
- Y + - - - START Y - Y -
|
||||
Y Y - - - ERROR Y - - -
|
||||
- Y - - Y GOTDROP - - - -
|
||||
- Y + - - Y GOTDROP START Y - Y -
|
||||
Y Y - - Y GOTDROP START Y - Y -
|
||||
Y Y - - - Y GOTDROP - - - -
|
||||
- Y - - - - - - -
|
||||
Y Y - - - - - - - -
|
||||
|
||||
"Set expS+ and start a task whenever expS+ is clear and demand
|
||||
becomes or remains high and supply becomes or remains low UNLESS
|
||||
demand is already high, supply drops, and expS- is clear, which is
|
||||
the 'unexpected drop' error case."
|
||||
|
||||
- - + - - START Y - Y -
|
||||
- Y + - - - START Y - Y -
|
||||
Y Y - - - ERROR Y - - -
|
||||
- Y + - - Y GOTDROP START Y - Y -
|
||||
Y Y - - Y GOTDROP START Y - Y -
|
||||
|
||||
"Clear expS+ whenever supply increases."
|
||||
|
||||
Y - + - - RECOVER Y Y - -
|
||||
Y - - + - - RECOVER EXPDROP - Y - Y
|
||||
Y - + Y - RUNNING Y Y - -
|
||||
Y - - + Y - RUNNING EXPDROP - Y - Y
|
||||
- - + Y Y RUNNING - Y - Y
|
||||
- - + + Y Y RUNNING Y Y - Y
|
||||
Y - + Y Y RUNNING Y Y - Y
|
||||
Y - - + Y Y RUNNING - Y - Y
|
||||
- - + - - - Y - -
|
||||
- - + + - - Y Y - -
|
||||
|
||||
By looking at the next-state columns corresponding to the action
|
||||
described, we can see that each predicate used to decide whether to
|
||||
set or clear each state bit is a sound overapproximation of the
|
||||
behaviour we want.
|
Binary file not shown.
After Width: | Height: | Size: 69 KiB |
|
@ -1,16 +0,0 @@
|
|||
#lang prospect ;; -*- racket -*-
|
||||
|
||||
(require "../drivers/tcp.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
|
||||
(define server-id (tcp-listener 5999))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
(actor (forever
|
||||
(on (asserted (advertise (tcp-channel $c server-id ?)))
|
||||
(printf "Accepted connection from ~v\n" c)
|
||||
(actor (until (retracted (advertise (tcp-channel c server-id ?)))
|
||||
(advertise (tcp-channel server-id c ?))
|
||||
(on (tcp-channel c server-id bs)
|
||||
(send! (tcp-channel server-id c bs))))
|
||||
(printf "Closed connection ~v\n" c)))))
|
|
@ -0,0 +1,2 @@
|
|||
scratch/
|
||||
compiled/
|
|
@ -0,0 +1,7 @@
|
|||
all:
|
||||
|
||||
run:
|
||||
raco make main.rkt && racket main.rkt
|
||||
|
||||
clean:
|
||||
rm -rf compiled
|
|
@ -0,0 +1,17 @@
|
|||
Try changing the motd and saving the file. It'll reload. The log
|
||||
messages suggest that the server is dropping extant connection - as
|
||||
expected - but it immediately comes back momentarily before going away
|
||||
properly. The session is able to reboot due to the glitching in
|
||||
assertion of the listen port *more quickly* than the latency of
|
||||
teardown of the previous connection; so the new session-listener
|
||||
responds to the assertions from the old connection before the old
|
||||
connection has a chance to die. Of course, it *does* die (since commit
|
||||
11de40c), but having that zombie reborn new session is annoying.
|
||||
|
||||
- This is thorny. You'd think that having a session wait for its
|
||||
line-reader to go would be enough, but the multiple nested
|
||||
during/spawns creating the sessions mean that no matter how long
|
||||
the old session instance sticks around, a new session will appear
|
||||
before we're ready! ... maybe there's no way *at all* to
|
||||
disambiguate old/new instances without, say, a unique
|
||||
listener-socket identifier??
|
|
@ -0,0 +1,24 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "protocol.rkt")
|
||||
(require "message.rkt")
|
||||
|
||||
(require/activate syndicate/reload)
|
||||
|
||||
(spawn #:name 'channel-factory
|
||||
(stop-when-reloaded)
|
||||
(during/spawn (ircd-channel-member $Ch _)
|
||||
#:name `(ircd-channel ,Ch)
|
||||
(field [topic #f])
|
||||
(assert (ircd-channel-topic Ch (topic)))
|
||||
|
||||
(on (message (ircd-action $who (irc-message _ "MODE" (list Ch "b") _)))
|
||||
(send! (ircd-event who (irc-message server-prefix 368 (list (lookup-nick who) Ch)
|
||||
"End of Channel Ban List"))))
|
||||
|
||||
(on (message (ircd-action $who (irc-message _ "MODE" (list Ch) _)))
|
||||
(send! (ircd-event who (irc-message server-prefix 324
|
||||
(list (lookup-nick who) Ch "+") #f))))
|
||||
|
||||
(on (message (ircd-action _ (irc-message _ "TOPIC" (list Ch) $new-topic)))
|
||||
(topic new-topic))))
|
|
@ -0,0 +1,14 @@
|
|||
#lang syndicate
|
||||
|
||||
(require/activate syndicate/reload)
|
||||
(require/activate syndicate/supervise)
|
||||
(require/activate syndicate/drivers/config)
|
||||
|
||||
(require "protocol.rkt")
|
||||
|
||||
(spawn #:name 'config
|
||||
(stop-when-reloaded)
|
||||
|
||||
(assert (ircd-motd (list "Hello, world!")))
|
||||
|
||||
(assert (ircd-listener 6667)))
|
|
@ -0,0 +1,7 @@
|
|||
#lang syndicate
|
||||
|
||||
(require/activate syndicate/reload)
|
||||
|
||||
(spawn-reloader "config.rkt")
|
||||
(spawn-reloader "session.rkt")
|
||||
(spawn-reloader "channel.rkt")
|
|
@ -0,0 +1,93 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out irc-message)
|
||||
(struct-out irc-user)
|
||||
(struct-out irc-privmsg)
|
||||
|
||||
(struct-out irc-source-servername)
|
||||
(struct-out irc-source-nick)
|
||||
|
||||
parse-irc-message
|
||||
render-irc-message
|
||||
|
||||
;; TODO make these assertions in the dataspace:
|
||||
server-name
|
||||
server-prefix)
|
||||
|
||||
(require racket/string)
|
||||
(require racket/match)
|
||||
(require racket/format)
|
||||
|
||||
;; <message> ::= [':' <prefix> <SPACE> ] <command> <params> <crlf>
|
||||
;; <prefix> ::= <servername> | <nick> [ '!' <user> ] [ '@' <host> ]
|
||||
;; <command> ::= <letter> { <letter> } | <number> <number> <number>
|
||||
;; <SPACE> ::= ' ' { ' ' }
|
||||
;; <params> ::= <SPACE> [ ':' <trailing> | <middle> <params> ]
|
||||
;;
|
||||
;; <middle> ::= <Any *non-empty* sequence of octets not including SPACE
|
||||
;; or NUL or CR or LF, the first of which may not be ':'>
|
||||
;; <trailing> ::= <Any, possibly *empty*, sequence of octets not including
|
||||
;; NUL or CR or LF>
|
||||
;;
|
||||
;; <crlf> ::= CR LF
|
||||
|
||||
;; <target> ::= <to> [ "," <target> ]
|
||||
;; <to> ::= <channel> | <user> '@' <servername> | <nick> | <mask>
|
||||
;; <channel> ::= ('#' | '&') <chstring>
|
||||
;; <servername> ::= <host>
|
||||
;; <host> ::= see RFC 952 [DNS:4] for details on allowed hostnames
|
||||
;; <nick> ::= <letter> { <letter> | <number> | <special> }
|
||||
;; <mask> ::= ('#' | '$') <chstring>
|
||||
;; <chstring> ::= <any 8bit code except SPACE, BELL, NUL, CR, LF and
|
||||
;; comma (',')>
|
||||
|
||||
;; <user> ::= <nonwhite> { <nonwhite> }
|
||||
;; <letter> ::= 'a' ... 'z' | 'A' ... 'Z'
|
||||
;; <number> ::= '0' ... '9'
|
||||
;; <special> ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'
|
||||
|
||||
;; <nonwhite> ::= <any 8bit code except SPACE (0x20), NUL (0x0), CR
|
||||
;; (0xd), and LF (0xa)>
|
||||
|
||||
(struct irc-message (prefix command params trailing) #:prefab)
|
||||
(struct irc-user (username hostname realname) #:prefab)
|
||||
(struct irc-privmsg (source target text) #:prefab)
|
||||
|
||||
(struct irc-source-servername (servername) #:prefab)
|
||||
(struct irc-source-nick (nick user) #:prefab)
|
||||
|
||||
(define (parse-irc-message line0)
|
||||
(match (string-trim #:left? #f line0 #px"[\r\n]")
|
||||
[(pregexp #px"^:([^ ]+) +(.*)$" (list _ prefix rest)) (parse-command prefix rest)]
|
||||
[line (parse-command #f line)]))
|
||||
|
||||
(define (parse-command prefix line)
|
||||
(match-define (pregexp #px"^([^ ]+)( +([^:]+)?(:(.*))?)?$" (list _ command _ params _ rest)) line)
|
||||
(irc-message prefix
|
||||
(string-upcase command)
|
||||
(string-split (or params ""))
|
||||
rest))
|
||||
|
||||
;; libpurple's irc protocol support crashes (!) (SIGSEGV) if you send
|
||||
;; a prefix on a JOIN event from the server as just "nick" rather than
|
||||
;; "nick!user@host" - specifically, it will crash if "!" doesn't
|
||||
;; appear in the prefix.
|
||||
;;
|
||||
(define (render-irc-message m)
|
||||
(match-define (irc-message prefix command params trailing) m)
|
||||
(string-append (render-prefix prefix)
|
||||
(~a command)
|
||||
(if (pair? params) (string-append " " (string-join (map ~a params))) "")
|
||||
(if trailing (string-append " :" trailing) "")))
|
||||
|
||||
(define (render-prefix p)
|
||||
(match p
|
||||
[#f
|
||||
""]
|
||||
[(irc-source-servername servername)
|
||||
(format ":~a " servername)]
|
||||
[(irc-source-nick nick (irc-user username hostname _))
|
||||
(format ":~a!~a@~a " nick username hostname)]))
|
||||
|
||||
(define server-name "syndicate-ircd")
|
||||
(define server-prefix (irc-source-servername "syndicate-ircd.example"))
|
|
@ -0,0 +1,30 @@
|
|||
#lang syndicate
|
||||
|
||||
(provide (struct-out ircd-listener)
|
||||
(struct-out ircd-motd)
|
||||
|
||||
(struct-out ircd-connection-info)
|
||||
(struct-out ircd-channel-member)
|
||||
(struct-out ircd-channel-topic)
|
||||
|
||||
(struct-out ircd-action)
|
||||
(struct-out ircd-event)
|
||||
|
||||
lookup-nick)
|
||||
|
||||
;; A Connection is a TcpAddress
|
||||
|
||||
(struct ircd-listener (port) #:prefab) ;; assertion
|
||||
(struct ircd-motd (lines) #:prefab) ;; assertion
|
||||
|
||||
(struct ircd-connection-info (conn nick user) #:prefab) ;;assertion
|
||||
(struct ircd-channel-member (channel conn) #:prefab) ;; assertion
|
||||
(struct ircd-channel-topic (channel topic) #:prefab) ;; assertion
|
||||
|
||||
(struct ircd-action (conn message) #:prefab) ;; message
|
||||
(struct ircd-event (conn message) #:prefab) ;; message
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (lookup-nick conn)
|
||||
(immediate-query [query-value #f (ircd-connection-info conn $N _) N]))
|
|
@ -0,0 +1,177 @@
|
|||
#lang syndicate
|
||||
|
||||
(require racket/set)
|
||||
(require racket/string)
|
||||
|
||||
(require "protocol.rkt")
|
||||
(require "message.rkt")
|
||||
|
||||
(require/activate syndicate/reload)
|
||||
(require/activate syndicate/drivers/tcp)
|
||||
(require/activate syndicate/drivers/line-reader)
|
||||
(require syndicate/protocol/advertise)
|
||||
(require syndicate/support/hash)
|
||||
|
||||
(define (ircd-connection-facet this-conn server-handle)
|
||||
(define (send-to-remote #:newline [with-newline #t] fmt . vs)
|
||||
(define bs (string->bytes/utf-8 (apply format fmt vs)))
|
||||
(log-info "~a <- ~v" this-conn bs)
|
||||
(send! (tcp-channel server-handle this-conn (if with-newline (bytes-append bs #"\r\n") bs))))
|
||||
|
||||
(define (send-irc-message m)
|
||||
(send-to-remote "~a" (render-irc-message m)))
|
||||
|
||||
(define (send* #:source [prefix server-prefix] #:trailing [trailing #f] command . params)
|
||||
(send-irc-message (irc-message prefix command params trailing)))
|
||||
|
||||
(on-start (log-info "Connecting ~a" this-conn))
|
||||
(on-stop (log-info "Disconnecting ~a" this-conn))
|
||||
|
||||
(field [nick #f]
|
||||
[user #f])
|
||||
(define/dataflow conn-info (ircd-connection-info this-conn (nick) (user)))
|
||||
(assert (conn-info))
|
||||
|
||||
(on-start
|
||||
(react
|
||||
(stop-when (asserted (ircd-motd $motd-lines))
|
||||
(react
|
||||
(begin/dataflow
|
||||
(when (and (nick) (user))
|
||||
(send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name))
|
||||
(for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line)))
|
||||
(send* 376 (nick) #:trailing (format "End of /MOTD command"))
|
||||
(stop-current-facet)))))))
|
||||
|
||||
(field [peer-common-channels (hash)]
|
||||
[peer-names (hash)])
|
||||
|
||||
(during (ircd-channel-member $Ch this-conn)
|
||||
(field [initial-names-sent? #f]
|
||||
[initial-member-nicks (set)])
|
||||
|
||||
(on-start (send* #:source (irc-source-nick (nick) (user)) "JOIN" Ch)
|
||||
(flush!)
|
||||
(flush!)
|
||||
(define nicks (initial-member-nicks))
|
||||
(initial-names-sent? #t)
|
||||
(initial-member-nicks 'no-longer-valid)
|
||||
(send* 353 (nick) "@" Ch #:trailing (string-join (set->list nicks)))
|
||||
(send* 366 (nick) Ch #:trailing "End of /NAMES list"))
|
||||
|
||||
(during (ircd-channel-member Ch $other-conn)
|
||||
(on-start (peer-common-channels (hashset-add (peer-common-channels) other-conn Ch)))
|
||||
(on-stop (peer-common-channels (hashset-remove (peer-common-channels) other-conn Ch)))
|
||||
(field [current-other-source #f])
|
||||
(define/query-value next-other-source #f
|
||||
(ircd-connection-info other-conn $N $U)
|
||||
(irc-source-nick N U))
|
||||
(on (retracted (ircd-channel-member Ch other-conn))
|
||||
(when (current-other-source) (send* #:source (current-other-source) "PART" Ch)))
|
||||
(on-stop (when (not (hash-has-key? (peer-common-channels) other-conn))
|
||||
(peer-names (hash-remove (peer-names) other-conn))))
|
||||
(begin/dataflow
|
||||
(when (not (equal? (current-other-source) (next-other-source)))
|
||||
(if (not (next-other-source)) ;; other-conn is disconnecting
|
||||
(when (hash-ref (peer-names) other-conn #f)
|
||||
(send* #:source (current-other-source) "QUIT")
|
||||
(peer-names (hash-remove (peer-names) other-conn)))
|
||||
(begin
|
||||
(cond
|
||||
[(not (initial-names-sent?)) ;; still gathering data for 353/366 below
|
||||
(initial-member-nicks (set-add (initial-member-nicks)
|
||||
(irc-source-nick-nick (next-other-source))))]
|
||||
[(not (current-other-source)) ;; other-conn is joining
|
||||
(send* #:source (next-other-source) "JOIN" Ch)]
|
||||
[else ;; it's a nick change
|
||||
(when (not (equal? this-conn other-conn)) ;; avoid dups for our own connection
|
||||
(when (not (equal? (next-other-source) (hash-ref (peer-names) other-conn #f)))
|
||||
(send* #:source (current-other-source) "NICK"
|
||||
(irc-source-nick-nick (next-other-source)))))])
|
||||
(peer-names (hash-set (peer-names) other-conn (next-other-source)))))
|
||||
(current-other-source (next-other-source)))))
|
||||
|
||||
(on (asserted (ircd-channel-topic Ch $topic))
|
||||
(if topic
|
||||
(send* 332 (nick) Ch #:trailing topic)
|
||||
(send* 331 (nick) Ch #:trailing "No topic is set")))
|
||||
|
||||
(on (message (ircd-action this-conn (irc-message _ "WHO" (list Ch) _)))
|
||||
(flush!) ;; Wait for responses to come in. GROSS and not in
|
||||
;; general correct (e.g. in the presence of
|
||||
;; pipelining)
|
||||
(send! (ircd-event this-conn
|
||||
(irc-message server-prefix 315 (list (nick) Ch) "End of WHO list."))))
|
||||
(on (message (ircd-action $who (irc-message _ "WHO" (list Ch) _)))
|
||||
(match-define (irc-user U H R) (user))
|
||||
(send! (ircd-event who (irc-message server-prefix 352
|
||||
(list (nick) Ch U H server-name (nick) "H")
|
||||
(format "0 ~a" R)))))
|
||||
|
||||
(on (message (ircd-action $other-conn (irc-privmsg $source Ch $text)))
|
||||
(when (not (equal? other-conn this-conn))
|
||||
(send* #:source source "PRIVMSG" Ch #:trailing text))))
|
||||
|
||||
(on (message (ircd-event this-conn $m))
|
||||
(send-irc-message m))
|
||||
|
||||
(on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text)))
|
||||
(when (not (equal? other-conn this-conn))
|
||||
(send* #:source source "PRIVMSG" (nick) #:trailing text)))
|
||||
|
||||
(on (message (tcp-channel-line this-conn server-handle $bs))
|
||||
(define m (parse-irc-message (bytes->string/utf-8 bs)))
|
||||
(log-info "~a -> ~v" this-conn m)
|
||||
(send! (ircd-action this-conn m))
|
||||
(match m
|
||||
[(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs
|
||||
[(or (irc-message _ "NICK" (list N) _)
|
||||
(irc-message _ "NICK" '() N)) ;; libpurple does this (!)
|
||||
;; TODO: enforce syntactic restrictions on nick
|
||||
(if (immediate-query [query-value #f (ircd-connection-info _ N _) #t])
|
||||
(send* 433 N #:trailing "Nickname is already in use")
|
||||
(begin (when (nick) (send* #:source (irc-source-nick (nick) (user)) "NICK" N))
|
||||
(nick N)))]
|
||||
[(irc-message _ "USER" (list U _Hostname _Servername) R)
|
||||
;; TODO: enforce syntactic restrictions on parameters to USER
|
||||
(define H (tcp-address-host this-conn))
|
||||
(user (irc-user U H R))]
|
||||
[(irc-message _ "QUIT" _ _) (stop-current-facet)]
|
||||
[_
|
||||
(when (and (nick) (user))
|
||||
(match m
|
||||
[(irc-message _ "JOIN" (cons Channels _MaybeKeys) _)
|
||||
(for [(Ch (string-split Channels #px",+"))]
|
||||
(assert! (ircd-channel-member Ch this-conn)))]
|
||||
[(irc-message _ "PART" (list Channels) _)
|
||||
(for [(Ch (string-split Channels #px",+"))]
|
||||
(retract! (ircd-channel-member Ch this-conn)))]
|
||||
[(irc-message _ "WHOIS" _ _)
|
||||
(send* 318 (nick) #:trailing "End of /WHOIS list")] ;; TODO
|
||||
[(irc-message _ "PRIVMSG" (list Targets) Text)
|
||||
(for [(T (string-split Targets #px",+"))]
|
||||
(send! (ircd-action this-conn
|
||||
(irc-privmsg (irc-source-nick (nick) (user)) T Text))))]
|
||||
[_ (void)]))])))
|
||||
|
||||
(spawn #:name 'ison-responder
|
||||
(stop-when-reloaded)
|
||||
(define/query-set nicks (ircd-connection-info _ $N _) N)
|
||||
(on (message (ircd-action $conn (irc-message _ "ISON" $SomeNicks $MoreNicks)))
|
||||
(define Nicks (append SomeNicks (string-split (or MoreNicks ""))))
|
||||
(define (on? N) (set-member? (nicks) N))
|
||||
(define Present (string-join (filter on? Nicks) " "))
|
||||
(send! (ircd-event conn (irc-message server-prefix 303 '("*") Present)))))
|
||||
|
||||
(spawn #:name 'session-listener-factory
|
||||
(stop-when-reloaded)
|
||||
(during/spawn (ircd-listener $port)
|
||||
#:name (ircd-listener port)
|
||||
(on-start (log-info "Listening on port ~a." port))
|
||||
(on-stop (log-info "No longer listening on port ~a." port))
|
||||
(define server-handle (tcp-listener port))
|
||||
(assert (advertise (observe (tcp-channel _ server-handle _))))
|
||||
(during/spawn (advertise (tcp-channel $this-conn server-handle _))
|
||||
#:name `(ircd-connection ,this-conn ,server-handle)
|
||||
(assert (advertise (tcp-channel server-handle this-conn _)))
|
||||
(ircd-connection-facet this-conn server-handle))))
|
|
@ -0,0 +1 @@
|
|||
compiled/
|
|
@ -0,0 +1,29 @@
|
|||
# TCP/IP Stack
|
||||
|
||||
There are two (closely-related) implementations here:
|
||||
|
||||
- [`monolithic-lowlevel`](monolithic-lowlevel/) is the original
|
||||
implementation, originally written for `minimart`, a language that
|
||||
followed our ESOP 2014 paper quite closely. Porting it to a
|
||||
monolithic-assertion-set Syndicate dialect helped substantially
|
||||
simplify the code.
|
||||
|
||||
- [`incremental-highlevel`](incremental-highlevel/) is a port of
|
||||
`monolithic-lowlevel` to the Syndicate high-level DSL
|
||||
("`syndicate/actor`"). Moving from the low-level Syndicate style to
|
||||
the high-level style also drastically simplified the code.
|
||||
|
||||
## 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
|
|
@ -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.
|
|
@ -0,0 +1,12 @@
|
|||
all:
|
||||
|
||||
run:
|
||||
raco make main.rkt && racket main.rkt
|
||||
|
||||
clean:
|
||||
find . -name compiled -type d | xargs rm -rf
|
||||
rm -f cpingresp
|
||||
|
||||
cpingresp: cpingresp.c
|
||||
$(CC) -o $@ $<
|
||||
sudo setcap cap_net_raw+p+i+e $@
|
|
@ -0,0 +1,196 @@
|
|||
#lang 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)
|
||||
spawn-arp-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require/activate syndicate/drivers/timer)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "configuration.rkt")
|
||||
(require/activate "ethernet.rkt")
|
||||
|
||||
(struct arp-query (protocol protocol-address interface link-address) #:prefab)
|
||||
(struct arp-assertion (protocol protocol-address interface-name) #:prefab)
|
||||
(struct arp-interface (interface-name) #:prefab)
|
||||
|
||||
(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))
|
||||
(on-start (define hwaddr (lookup-ethernet-hwaddr interface-name))
|
||||
(when (not hwaddr)
|
||||
(error 'arp "Failed to look up ARP interface ~v"
|
||||
interface-name))
|
||||
(react (run-arp-interface interface-name hwaddr))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(struct cache-key (protocol address) #:transparent)
|
||||
(struct cache-value (expiry interface 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 interface (ethernet-interface 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
|
||||
#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)])
|
||||
|
||||
(on-start (define timer-key (list 'arp interface-name))
|
||||
(define (arm-timer!) (send! (set-timer timer-key wakeup-interval 'relative)))
|
||||
(arm-timer!)
|
||||
(react (on (message (timer-expired timer-key _))
|
||||
(cache (expire-cache (cache)))
|
||||
(send-questions!)
|
||||
(arm-timer!))))
|
||||
|
||||
(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
|
||||
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 _))
|
||||
(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)
|
|
@ -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))
|
|
@ -0,0 +1,21 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out ethernet-interface)
|
||||
(struct-out host-route)
|
||||
(struct-out gateway-route)
|
||||
(struct-out net-route)
|
||||
|
||||
(struct-out route-up))
|
||||
|
||||
(struct ethernet-interface (name hwaddr) #:prefab)
|
||||
|
||||
;; 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
|
|
@ -0,0 +1,219 @@
|
|||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdint.h>
|
||||
#include <ctype.h>
|
||||
|
||||
#include <sys/types.h>
|
||||
#include <sys/socket.h>
|
||||
#include <sys/time.h>
|
||||
#include <sys/ioctl.h>
|
||||
|
||||
#include <fcntl.h>
|
||||
#include <err.h>
|
||||
#include <errno.h>
|
||||
#include <unistd.h>
|
||||
#include <ifaddrs.h>
|
||||
|
||||
#include <net/if.h>
|
||||
#include <net/ethernet.h>
|
||||
#include <arpa/inet.h> /* for htons */
|
||||
|
||||
#include <pthread.h>
|
||||
|
||||
#include <net/if_arp.h>
|
||||
#include <netpacket/packet.h>
|
||||
|
||||
static int lookupInterfaceInfo(int sock, char const *interfaceName, int info, struct ifreq *ifr) {
|
||||
strncpy(ifr->ifr_name, interfaceName, IFNAMSIZ);
|
||||
if (ioctl(sock, info, ifr) < 0) {
|
||||
perror("ioctl error while looking performing ioctl on interface");
|
||||
fprintf(stderr, "(ioctl number 0x%08x, interface %s)\n", info, interfaceName);
|
||||
return -1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
static int bindToInterface(int sock, char const *interfaceName) {
|
||||
struct ifreq ifr;
|
||||
struct sockaddr_ll socketAddress;
|
||||
|
||||
if (lookupInterfaceInfo(sock, interfaceName, SIOCGIFINDEX, &ifr) < 0) {
|
||||
return -1;
|
||||
}
|
||||
|
||||
socketAddress.sll_family = AF_PACKET;
|
||||
socketAddress.sll_protocol = htons(ETH_P_ALL);
|
||||
socketAddress.sll_ifindex = ifr.ifr_ifindex;
|
||||
|
||||
if (bind(sock, (struct sockaddr *) &socketAddress, sizeof(socketAddress)) < 0) {
|
||||
perror("Bind error");
|
||||
return -1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int openSocket(char const *interfaceName) {
|
||||
int sock = socket(AF_PACKET, SOCK_RAW, htons(ETH_P_ALL));
|
||||
if (sock < 0) {
|
||||
perror("Socket error");
|
||||
return -1;
|
||||
}
|
||||
|
||||
if (bindToInterface(sock, interfaceName) == -1) {
|
||||
return -1;
|
||||
}
|
||||
|
||||
return sock;
|
||||
}
|
||||
|
||||
/* hwaddr should be of length ETH_ALEN */
|
||||
static int socket_hwaddr(int sock, char const *interfaceName, char *hwaddr) {
|
||||
struct ifreq ifr;
|
||||
|
||||
if (lookupInterfaceInfo(sock, interfaceName, SIOCGIFHWADDR, &ifr) < 0) {
|
||||
return -1;
|
||||
}
|
||||
|
||||
if (ifr.ifr_hwaddr.sa_family != ARPHRD_ETHER) {
|
||||
return -1;
|
||||
}
|
||||
|
||||
memcpy(hwaddr, ifr.ifr_hwaddr.sa_data, ETH_ALEN);
|
||||
return 0;
|
||||
}
|
||||
|
||||
static void dump_row(long count, int numinrow, int *chs) {
|
||||
int i;
|
||||
|
||||
printf("%08lX:", count - numinrow);
|
||||
|
||||
if (numinrow > 0) {
|
||||
for (i = 0; i < numinrow; i++) {
|
||||
if (i == 8)
|
||||
printf(" :");
|
||||
printf(" %02X", chs[i]);
|
||||
}
|
||||
for (i = numinrow; i < 16; i++) {
|
||||
if (i == 8)
|
||||
printf(" :");
|
||||
printf(" ");
|
||||
}
|
||||
printf(" ");
|
||||
for (i = 0; i < numinrow; i++) {
|
||||
if (isprint(chs[i]))
|
||||
printf("%c", chs[i]);
|
||||
else
|
||||
printf(".");
|
||||
}
|
||||
}
|
||||
printf("\n");
|
||||
}
|
||||
|
||||
static int rows_eq(int *a, int *b) {
|
||||
int i;
|
||||
|
||||
for (i=0; i<16; i++)
|
||||
if (a[i] != b[i])
|
||||
return 0;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
void dump_buffer_to_stdout(void *buf_v, int len, int hexmode) {
|
||||
unsigned char *buf = (unsigned char *) buf_v;
|
||||
long count = 0;
|
||||
int numinrow = 0;
|
||||
int chs[16];
|
||||
int oldchs[16];
|
||||
int showed_dots = 0;
|
||||
int i;
|
||||
|
||||
if (hexmode) {
|
||||
for (i = 0; i < len; i++) {
|
||||
int ch = buf[i];
|
||||
|
||||
if (numinrow == 16) {
|
||||
int i;
|
||||
|
||||
if (rows_eq(oldchs, chs)) {
|
||||
if (!showed_dots) {
|
||||
showed_dots = 1;
|
||||
printf(" .. .. .. .. .. .. .. .. : .. .. .. .. .. .. .. ..\n");
|
||||
}
|
||||
} else {
|
||||
showed_dots = 0;
|
||||
dump_row(count, numinrow, chs);
|
||||
}
|
||||
|
||||
for (i=0; i<16; i++)
|
||||
oldchs[i] = chs[i];
|
||||
|
||||
numinrow = 0;
|
||||
}
|
||||
|
||||
count++;
|
||||
chs[numinrow++] = ch;
|
||||
}
|
||||
|
||||
dump_row(count, numinrow, chs);
|
||||
|
||||
if (numinrow != 0)
|
||||
printf("%08lX:\n", count);
|
||||
} else {
|
||||
fwrite(buf, 1, len, stdout);
|
||||
printf("\n");
|
||||
fflush(NULL);
|
||||
}
|
||||
}
|
||||
|
||||
int main(int argc, char const *argv[]) {
|
||||
int handle = openSocket("eth0");
|
||||
uint8_t buf[65536];
|
||||
|
||||
while (1) {
|
||||
ssize_t len = recv(handle, &buf[0], sizeof(buf), MSG_TRUNC);
|
||||
if (len == -1) {
|
||||
perror("recv");
|
||||
break;
|
||||
}
|
||||
|
||||
uint8_t *ipbuf = buf + 14;
|
||||
|
||||
uint32_t self_ip = 0x810a735e;
|
||||
|
||||
uint32_t remote_ip = ntohl(*(int *)(&ipbuf[12]));
|
||||
uint32_t local_ip = ntohl(*(int *)(&ipbuf[16]));
|
||||
|
||||
if (local_ip == self_ip) {
|
||||
printf("Got ping from %d.%d.%d.%d\n", ipbuf[12], ipbuf[13], ipbuf[14], ipbuf[15]);
|
||||
if ((len >= 28) && (ipbuf[9] == 1) && (ipbuf[20] == 8)) {
|
||||
ipbuf[20] = 0;
|
||||
{
|
||||
short *icmp_cksum = (short *) (&ipbuf[22]);
|
||||
*icmp_cksum = htons(ntohs(*icmp_cksum) + 0x0800);
|
||||
}
|
||||
*(int *)(&ipbuf[12]) = htonl(local_ip);
|
||||
*(int *)(&ipbuf[16]) = htonl(remote_ip);
|
||||
|
||||
{
|
||||
uint8_t mac[6];
|
||||
memcpy(mac, buf, 6);
|
||||
memcpy(buf, buf+6, 6);
|
||||
memcpy(buf+6, mac, 6);
|
||||
}
|
||||
{
|
||||
ssize_t written = write(handle, buf, len);
|
||||
if (written != len) {
|
||||
perror("write");
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
|
@ -0,0 +1,21 @@
|
|||
#lang 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))]))
|
|
@ -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))
|
|
@ -0,0 +1,125 @@
|
|||
#lang syndicate
|
||||
;; Ethernet driver
|
||||
|
||||
(provide (struct-out ethernet-packet)
|
||||
zero-ethernet-address
|
||||
broadcast-ethernet-address
|
||||
interface-names
|
||||
spawn-ethernet-driver
|
||||
ethernet-packet-pattern
|
||||
lookup-ethernet-hwaddr)
|
||||
|
||||
(require/activate 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")
|
||||
|
||||
(struct ethernet-packet (interface from-wire? source destination ethertype body) #:prefab)
|
||||
|
||||
(define zero-ethernet-address (bytes 0 0 0 0 0 0))
|
||||
(define broadcast-ethernet-address (bytes 255 255 255 255 255 255))
|
||||
|
||||
(define interface-names (raw-interface-names))
|
||||
(log-info "Device names: ~a" interface-names)
|
||||
|
||||
(define (spawn-ethernet-driver)
|
||||
(spawn #:name 'ethernet-driver
|
||||
(during/spawn
|
||||
(observe (ethernet-packet (ethernet-interface $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)
|
||||
|
||||
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
|
||||
(assert interface)
|
||||
|
||||
(define control-ch (make-async-channel))
|
||||
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
|
||||
|
||||
(on-start (flush!) ;; ensure all subscriptions are in place
|
||||
(async-channel-put control-ch 'unblock)
|
||||
(spawn #:name (list 'ethernet-interface-quit-monitor interface-name)
|
||||
(on (retracted interface)
|
||||
(async-channel-put control-ch 'quit))))
|
||||
|
||||
(on (message (inbound ($ 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)))
|
||||
(send! p))
|
||||
|
||||
(on (message ($ p (ethernet-packet interface #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 h control-ch)
|
||||
(define (blocked)
|
||||
(match (async-channel-get control-ch)
|
||||
['unblock (unblocked)]
|
||||
['quit (void)]))
|
||||
(define (unblocked)
|
||||
(match (async-channel-try-get control-ch)
|
||||
['unblock (unblocked)]
|
||||
['quit (void)]
|
||||
[#f
|
||||
(define p (raw-interface-read h))
|
||||
(define decoded (decode-ethernet-packet interface p))
|
||||
(when decoded (send-ground-message decoded))
|
||||
(unblocked)]))
|
||||
(blocked)
|
||||
(raw-interface-close h))
|
||||
|
||||
(define (decode-ethernet-packet interface p)
|
||||
(bit-string-case p
|
||||
([ (destination :: binary bytes 6)
|
||||
(source :: binary bytes 6)
|
||||
(ethertype :: integer bytes 2)
|
||||
(body :: binary) ]
|
||||
(ethernet-packet interface
|
||||
#t
|
||||
(bit-string->bytes source)
|
||||
(bit-string->bytes destination)
|
||||
ethertype
|
||||
(bit-string->bytes body)))
|
||||
(else #f)))
|
||||
|
||||
(define (encode-ethernet-packet p)
|
||||
(match-define (ethernet-packet _ _ source destination ethertype body) p)
|
||||
(bit-string->bytes
|
||||
(bit-string (destination :: binary bytes 6)
|
||||
(source :: binary bytes 6)
|
||||
(ethertype :: integer bytes 2)
|
||||
(body :: binary))))
|
||||
|
||||
(define (ethernet-packet-pattern interface-name from-wire? ethertype)
|
||||
(ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?))
|
||||
|
||||
(define (lookup-ethernet-hwaddr interface-name)
|
||||
(define timer-id (gensym 'lookup-ethernet-hwaddr))
|
||||
(react/suspend (k)
|
||||
(on-start (send! (set-timer timer-id 5000 'relative)))
|
||||
(stop-when (message (timer-expired timer-id _))
|
||||
(log-info "Lookup of ethernet interface ~v failed" interface-name)
|
||||
(k #f))
|
||||
(stop-when (asserted (ethernet-interface interface-name $hwaddr))
|
||||
(k hwaddr))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn-ethernet-driver)
|
|
@ -0,0 +1,26 @@
|
|||
#lang syndicate
|
||||
|
||||
(require/activate 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 ()
|
||||
(define local-handle (tcp-handle 'httpclient))
|
||||
(define remote-handle (tcp-address "81.4.107.66" 80))
|
||||
|
||||
(actor (assert (advertise (tcp-channel local-handle remote-handle _)))
|
||||
(on (asserted (advertise (tcp-channel remote-handle local-handle _)))
|
||||
(send! (tcp-channel local-handle
|
||||
remote-handle
|
||||
#"GET / HTTP/1.0\r\nHost: leastfixedpoint.com\r\n\r\n")))
|
||||
(stop-when (retracted (advertise (tcp-channel remote-handle local-handle _)))
|
||||
(printf "URL fetcher exiting.\n"))
|
||||
(on (message (tcp-channel remote-handle local-handle $bs))
|
||||
(printf "----------------------------------------\n~a\n" bs)
|
||||
(printf "----------------------------------------\n"))))
|
|
@ -0,0 +1,268 @@
|
|||
#lang 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 syndicate/protocol/advertise)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "configuration.rkt")
|
||||
(require "checksum.rkt")
|
||||
|
||||
(require/activate syndicate/drivers/timer)
|
||||
(require/activate "ethernet.rkt")
|
||||
(require/activate "arp.rkt")
|
||||
|
||||
(struct ip-packet (source-interface ;; string for an ethernet interface, or #f for local interfaces
|
||||
source
|
||||
destination
|
||||
protocol
|
||||
options
|
||||
body)
|
||||
#:prefab) ;; TODO: more fields
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (ip-address->hostname bs)
|
||||
(bit-string-case bs
|
||||
([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
|
||||
|
||||
(define (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 (advertise (ip-packet _ my-address _ PROTOCOL-ICMP _ _)))
|
||||
(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
|
||||
|
||||
(struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent)
|
||||
|
||||
(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))
|
||||
|
||||
(field [gateway-interface #f]
|
||||
[gateway-hwaddr #f])
|
||||
(on (asserted (arp-query IPv4-ethertype
|
||||
gateway-addr
|
||||
($ iface (ethernet-interface interface-name _))
|
||||
$hwaddr))
|
||||
(when (not (gateway-hwaddr))
|
||||
(log-info "Discovered gateway ~a at ~a on interface ~a."
|
||||
(ip-address->hostname gateway-addr)
|
||||
(ethernet-interface-name iface)
|
||||
(pretty-bytes hwaddr)))
|
||||
(gateway-interface iface)
|
||||
(gateway-hwaddr hwaddr))
|
||||
|
||||
(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))))
|
||||
|
||||
(on (message ($ p (ip-packet _ _ _ _ _ _)))
|
||||
(when (not (gateway-interface))
|
||||
(log-warning "Gateway hwaddr for ~a not known, packet dropped."
|
||||
(ip-address->hostname gateway-addr)))
|
||||
(when (and (gateway-interface)
|
||||
(not (equal? (ip-packet-source-interface p)
|
||||
(ethernet-interface-name (gateway-interface))))
|
||||
(not (covered-by-some-other-route? (ip-packet-destination p))))
|
||||
(send! (ethernet-packet (gateway-interface)
|
||||
#f
|
||||
(ethernet-interface-hwaddr (gateway-interface))
|
||||
(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 (ethernet-interface interface-name _) #t _ _ IPv4-ethertype $body))
|
||||
(define p (parse-ip-packet interface-name body))
|
||||
(when p (send! p)))
|
||||
(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))
|
||||
(define timer-id (gensym 'ippkt))
|
||||
;; v Use `spawn` instead of `react` to avoid gratuitous packet
|
||||
;; reordering.
|
||||
(spawn (on-start (send! (set-timer timer-id 5000 'relative)))
|
||||
(stop-when (message (timer-expired timer-id _))
|
||||
(log-warning "ARP lookup of ~a failed, packet dropped"
|
||||
(ip-address->hostname destination)))
|
||||
(stop-when (asserted (arp-query IPv4-ethertype
|
||||
destination
|
||||
($ interface (ethernet-interface interface-name _))
|
||||
$destination-hwaddr))
|
||||
(send! (ethernet-packet interface
|
||||
#f
|
||||
(ethernet-interface-hwaddr interface)
|
||||
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)
|
|
@ -0,0 +1,91 @@
|
|||
#lang syndicate
|
||||
|
||||
(require syndicate/protocol/advertise)
|
||||
|
||||
(require/activate 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 (only-in racket/string string-trim))
|
||||
|
||||
(struct says (who what) #:prefab)
|
||||
(struct present (who) #:prefab)
|
||||
|
||||
(define (spawn-session them us)
|
||||
(spawn (define (send-to-remote fmt . vs)
|
||||
(send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
|
||||
|
||||
(define (say who fmt . vs)
|
||||
(unless (equal? who user)
|
||||
(send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
|
||||
(define user (gensym 'user))
|
||||
(on-start (send-to-remote "Welcome, ~a.\n" user))
|
||||
|
||||
(stop-when (retracted (inbound (advertise (tcp-channel them us _)))))
|
||||
|
||||
(assert (present user))
|
||||
(on (asserted (present $who)) (say who "arrived."))
|
||||
(on (retracted (present $who)) (say who "departed."))
|
||||
|
||||
(on (message (says $who $what)) (say who "says: ~a" what))
|
||||
|
||||
(assert (outbound (advertise (tcp-channel us them _))))
|
||||
(on (message (inbound (tcp-channel them us $bs)))
|
||||
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))
|
||||
|
||||
(define us (tcp-listener 5999))
|
||||
(dataspace #:name 'chat-dataspace
|
||||
(spawn #:name 'chat-server
|
||||
(assert (outbound (advertise (observe (tcp-channel _ us _)))))
|
||||
(on (asserted (inbound (advertise (tcp-channel $them us _))))
|
||||
(spawn-session them us)))))
|
||||
|
||||
(let ((dst (udp-listener 6667)))
|
||||
(spawn #:name 'udp-echo-program
|
||||
(on (message (udp-packet $src dst $body))
|
||||
(log-info "Got packet from ~v: ~v" src body)
|
||||
(send! (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 (assert (outbound (advertise (observe (tcp-channel _ us _)))))
|
||||
(during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
|
||||
#:name (list 'webserver-session them)
|
||||
(log-info "Got connection from ~v" them)
|
||||
(assert (outbound (advertise (tcp-channel us them _))))
|
||||
(on (message (inbound (tcp-channel them us _)))) ;; 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-channel us them response)))
|
||||
(for [(i 4)]
|
||||
(define buf (make-bytes 1024 (+ #x30 i)))
|
||||
(send! (outbound (tcp-channel us them buf))))
|
||||
(stop-facet (current-facet-id)))))))
|
|
@ -0,0 +1,67 @@
|
|||
#lang racket/base
|
||||
;; Simple "ping" responder. Nightmarishly oversimplified. We want to
|
||||
;; look at overheads excluding Syndicate. See also
|
||||
;; http://dunkels.com/adam/twip.html
|
||||
|
||||
(require packet-socket)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
|
||||
(define device-name (or (getenv "PINGRESP_DEVICE") "eth0"))
|
||||
(define self-ip (integer-bytes->integer (bytes 129 10 115 94) #f #t))
|
||||
|
||||
(define handle (raw-interface-open device-name))
|
||||
(unless handle (error 'pingresp "Couldn't open ~a" device-name))
|
||||
|
||||
(let loop ()
|
||||
(define eth-buffer (raw-interface-read handle))
|
||||
(define buffer (subbytes eth-buffer 14))
|
||||
(when (>= (bytes-length buffer) 20) ;; enough space for local and remote IP addresses
|
||||
(define local-ip (integer-bytes->integer buffer #f #t 16 20))
|
||||
(define remote-ip (integer-bytes->integer buffer #f #t 12 16))
|
||||
(when (= local-ip self-ip)
|
||||
;; (printf "Got ping from ~v\n" (bytes->list (subbytes buffer 12 16)))
|
||||
;; (flush-output)
|
||||
;; (dump-bytes! eth-buffer)
|
||||
;; (newline)
|
||||
|
||||
(when (and (>= (bytes-length buffer) 28) ;; IP + ICMP headers
|
||||
(= (bytes-ref buffer 9) 1) ;; IP protocol
|
||||
(= (bytes-ref buffer 20) 8) ;; ICMP ECHO
|
||||
)
|
||||
|
||||
(bytes-set! buffer 20 0) ;; ICMP ECHO_REPLY
|
||||
(integer->integer-bytes (bitwise-and #xffff
|
||||
(+ #x0800
|
||||
(integer-bytes->integer buffer #f #t 22 24)))
|
||||
2 #f #t buffer 22) ;; "fix" checksum
|
||||
(integer->integer-bytes local-ip 4 #f #t buffer 12)
|
||||
(integer->integer-bytes remote-ip 4 #f #t buffer 16)
|
||||
|
||||
(define reply
|
||||
(bytes-append (subbytes eth-buffer 6 12)
|
||||
(subbytes eth-buffer 0 6)
|
||||
(subbytes eth-buffer 12 14)
|
||||
buffer))
|
||||
;; (displayln "Reply:")
|
||||
;; (dump-bytes! reply)
|
||||
;; (newline)
|
||||
(raw-interface-write handle reply))))
|
||||
(loop))
|
||||
|
||||
(raw-interface-close handle)
|
||||
|
||||
|
||||
;; short s[70];
|
||||
;; int *l = s;
|
||||
;; int t;
|
||||
;;
|
||||
;; read(0, s, 140);
|
||||
;; if((s[4] & 65280) == 256 & s[10] == 8) {
|
||||
;; s[10] = 0;
|
||||
;; s[11] += 8;
|
||||
;; t = l[4];
|
||||
;; l[4] = l[3];
|
||||
;; l[3] = t;
|
||||
;; write(1, s, 140);
|
||||
;; }
|
|
@ -0,0 +1,36 @@
|
|||
#lang 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)))))
|
|
@ -0,0 +1,797 @@
|
|||
#lang syndicate
|
||||
|
||||
(provide (struct-out tcp-address)
|
||||
(struct-out tcp-handle)
|
||||
(struct-out tcp-listener)
|
||||
(struct-out tcp-channel)
|
||||
spawn-tcp-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require bitsyntax)
|
||||
(require syndicate/protocol/advertise)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "checksum.rkt")
|
||||
|
||||
(require/activate syndicate/drivers/timestate)
|
||||
(require "ip.rkt")
|
||||
(require "port-allocator.rkt")
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
(define-logger netstack/tcp)
|
||||
|
||||
;; tcp-address/tcp-address : "kernel" tcp connection state machines
|
||||
;; tcp-handle/tcp-address : "user" outbound connections
|
||||
;; tcp-listener/tcp-address : "user" inbound connections
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Protocol messages
|
||||
|
||||
(struct tcp-address (host port) #:prefab)
|
||||
(struct tcp-handle (id) #:prefab)
|
||||
(struct tcp-listener (port) #:prefab)
|
||||
|
||||
(struct tcp-channel (source destination subpacket) #:prefab)
|
||||
|
||||
(struct tcp-packet (from-wire?
|
||||
source-ip
|
||||
source-port
|
||||
destination-ip
|
||||
destination-port
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size
|
||||
options
|
||||
data)
|
||||
#:prefab)
|
||||
|
||||
;; (tcp-port-allocation Number (U TcpHandle TcpListener))
|
||||
(struct tcp-port-allocation (port handle) #:prefab)
|
||||
|
||||
(define (summarize-tcp-packet packet)
|
||||
(format "(~a) ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a, payload ~a)"
|
||||
(if (tcp-packet-from-wire? packet) "I" "O")
|
||||
(ip-address->hostname (tcp-packet-source-ip packet))
|
||||
(tcp-packet-source-port packet)
|
||||
(ip-address->hostname (tcp-packet-destination-ip packet))
|
||||
(tcp-packet-destination-port 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))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; User-accessible driver startup
|
||||
|
||||
(define (spawn-tcp-driver)
|
||||
(spawn-port-allocator 'tcp (lambda () (query-set tcp-ports (tcp-port-allocation $p _) p)))
|
||||
(spawn-kernel-tcp-driver)
|
||||
(spawn #:name 'tcp-inbound-driver
|
||||
(during/spawn (advertise (observe (tcp-channel _ ($ server-addr (tcp-listener _)) _)))
|
||||
#:name (list 'tcp-listen server-addr)
|
||||
(match-define (tcp-listener port) server-addr)
|
||||
(assert (tcp-port-allocation port server-addr))
|
||||
(on (asserted (advertise (tcp-channel ($ remote-addr (tcp-address _ _))
|
||||
($ local-addr (tcp-address _ port))
|
||||
_)))
|
||||
(spawn-relay server-addr remote-addr local-addr))))
|
||||
(spawn #:name 'tcp-outbound-driver
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
(on (asserted (advertise (tcp-channel ($ local-addr (tcp-handle _))
|
||||
($ remote-addr (tcp-address _ _))
|
||||
_)))
|
||||
(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
|
||||
;; "?". This would give us a form of mobility, where IP
|
||||
;; addresses only route to a given bucket-of-state and ONLY
|
||||
;; the port number selects a substate therein. That's not
|
||||
;; how TCP is defined however so we can't do that.
|
||||
(define appropriate-ip (set-first (local-ips)))
|
||||
(define appropriate-host (ip-address->hostname appropriate-ip))
|
||||
(match-define (tcp-address remote-host remote-port) remote-addr)
|
||||
(define remote-ip (ip-string->ip-address remote-host))
|
||||
(spawn-relay local-addr remote-addr (tcp-address appropriate-host port))
|
||||
(spawn-state-vector remote-ip remote-port appropriate-ip port))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Relay between kernel-level and user-level
|
||||
|
||||
(define relay-peer-wait-time-msec 5000)
|
||||
|
||||
(define (spawn-relay local-user-addr remote-addr local-tcp-addr)
|
||||
(define timer-name (list 'spawn-relay local-tcp-addr remote-addr))
|
||||
|
||||
(spawn #:name (list 'tcp-relay local-user-addr remote-addr local-tcp-addr)
|
||||
(assert (tcp-port-allocation (tcp-address-port local-tcp-addr) local-user-addr))
|
||||
(assert (advertise (tcp-channel remote-addr local-user-addr _)))
|
||||
(assert (advertise (tcp-channel local-tcp-addr remote-addr _)))
|
||||
|
||||
(field [local-peer-present? #f]
|
||||
[remote-peer-present? #f])
|
||||
|
||||
(on-timeout relay-peer-wait-time-msec
|
||||
(when (not (and (local-peer-present?) (remote-peer-present?)))
|
||||
(error 'spawn-relay "TCP relay process timed out waiting for peer")))
|
||||
|
||||
(on (asserted (observe (tcp-channel remote-addr local-user-addr _)))
|
||||
(local-peer-present? #t))
|
||||
(stop-when (retracted (observe (tcp-channel remote-addr local-user-addr _))))
|
||||
|
||||
(on (asserted (advertise (tcp-channel remote-addr local-tcp-addr _)))
|
||||
(remote-peer-present? #t))
|
||||
(stop-when (retracted (advertise (tcp-channel remote-addr local-tcp-addr _))))
|
||||
|
||||
(on (message (tcp-channel local-user-addr remote-addr $bs))
|
||||
(send! (tcp-channel local-tcp-addr remote-addr bs)))
|
||||
|
||||
(on (message (tcp-channel remote-addr local-tcp-addr $bs))
|
||||
(send! (tcp-channel remote-addr local-user-addr bs)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Codec & kernel-level driver
|
||||
|
||||
(define PROTOCOL-TCP 6)
|
||||
|
||||
(define (spawn-kernel-tcp-driver)
|
||||
(spawn #:name 'kernel-tcp-driver
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
|
||||
(define active-state-vectors
|
||||
(query-set active-state-vectors
|
||||
(observe (tcp-packet #t $si $sp $di $dp _ _ _ _ _ _))
|
||||
(list si sp di dp)))
|
||||
|
||||
(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 (list 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
|
||||
src-ip
|
||||
src-port
|
||||
dst-ip
|
||||
dst-port
|
||||
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 src-ip src-port dst-ip dst-port))
|
||||
(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
|
||||
src-ip
|
||||
src-port
|
||||
dst-ip
|
||||
dst-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))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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 src-ip src-port dst-ip dst-port)
|
||||
(define src (tcp-address (ip-address->hostname src-ip) src-port))
|
||||
(define dst (tcp-address (ip-address->hostname dst-ip) dst-port))
|
||||
|
||||
(spawn
|
||||
#:name (list 'tcp-state-vector
|
||||
(ip-address->hostname src-ip)
|
||||
src-port
|
||||
(ip-address->hostname dst-ip)
|
||||
dst-port)
|
||||
;; Spawn with initial assertions so we are guaranteed to be sent
|
||||
;; the packet that led to our creation (in the case of an accepted
|
||||
;; server connection), and so that we at the same moment gain
|
||||
;; knowledge of whether we were created on a listening port:
|
||||
#:assertions* (patch-added
|
||||
(patch-seq (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?))
|
||||
(sub (observe (advertise (tcp-channel ? (tcp-listener dst-port) ?))))))
|
||||
|
||||
(define root-facet (current-facet-id))
|
||||
|
||||
(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]
|
||||
|
||||
[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-channel src dst chunk))
|
||||
(inbound (struct-copy buffer b
|
||||
[data #""]
|
||||
[seqn (seq+ (buffer-seqn b) (bytes-length chunk))]))))
|
||||
|
||||
;; (Setof Symbol) -> Void
|
||||
(define (check-fin! flags)
|
||||
(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 (set-member? flags 'fin)
|
||||
(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
|
||||
|
||||
;; -> 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!)
|
||||
(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 dst-ip dst-port src-ip src-port
|
||||
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) (local-peer-seen?))
|
||||
;; ^ Talk only either if: we know the peer's seqn, or
|
||||
;; we don't, but a local peer exists, which means
|
||||
;; 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 dst-ip dst-port src-ip src-port
|
||||
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 #:when (and (syn-acked?) (not (buffer-finished? (inbound))))
|
||||
(advertise (tcp-channel src dst _)))
|
||||
|
||||
(on-start (log-netstack/tcp-info "Starting state vector ~a-~a" src-port dst-port))
|
||||
(on-stop (log-netstack/tcp-info "Stopping state vector ~a-~a" src-port dst-port))
|
||||
|
||||
(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 local-peer-seen? #f (observe (tcp-channel src dst _)) #t
|
||||
#:on-remove (begin
|
||||
(log-netstack/tcp-debug "Closing outbound stream.")
|
||||
(close-outbound-stream!)))
|
||||
|
||||
(define/query-value listener-listening?
|
||||
#f
|
||||
(observe (advertise (tcp-channel _ (tcp-listener dst-port) _)))
|
||||
#t)
|
||||
|
||||
(define (trigger-ack!)
|
||||
(transmission-needed? #t))
|
||||
|
||||
(on (message (tcp-packet #t src-ip src-port dst-ip dst-port
|
||||
$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 (local-peer-seen?))))) ;; ...and no outbound client
|
||||
(reset! ackn ;; this is *our* seqn
|
||||
(seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0)))
|
||||
;; ^^ this is what we should acknowledge...
|
||||
)]
|
||||
[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!)])
|
||||
(deliver-inbound-locally!)
|
||||
(check-fin! flags)
|
||||
(discard-acknowledged-outbound! (set-member? flags 'ack) ackn)
|
||||
(update-outbound-window! window)
|
||||
(latest-peer-activity-time (current-inexact-milliseconds))]))
|
||||
|
||||
(on (message (tcp-channel dst src $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)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(spawn-tcp-driver)
|
|
@ -0,0 +1,142 @@
|
|||
#lang 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 syndicate/protocol/advertise)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "checksum.rkt")
|
||||
(require "configuration.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)))
|
||||
|
||||
;; 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))
|
||||
|
||||
(define any-remote (udp-remote-address ? ?))
|
||||
|
||||
(stop-when (retracted (observe (udp-packet any-remote local-user-addr _))))
|
||||
(assert (advertise (udp-packet any-remote local-user-addr _)))
|
||||
(assert (udp-port-allocation local-port local-user-addr))
|
||||
|
||||
(during (host-route $ip _ _)
|
||||
(assert (advertise (udp-datagram ip local-port _ _ _)))
|
||||
(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 ($ remote-addr any-remote) $bs))
|
||||
;; Choose arbitrary local IP address for outbound packet!
|
||||
;; TODO: what can be done? Must I examine the routing table?
|
||||
(match-define (udp-remote-address remote-host remote-port) remote-addr)
|
||||
(define remote-ip (ip-string->ip-address remote-host))
|
||||
(send! (udp-datagram (set-first (local-ips))
|
||||
local-port
|
||||
remote-ip
|
||||
remote-port
|
||||
bs)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Codec & kernel-level driver
|
||||
|
||||
(define PROTOCOL-UDP 17)
|
||||
|
||||
(define (spawn-kernel-udp-driver)
|
||||
(spawn #:name 'kernel-udp-driver
|
||||
(assert (advertise (ip-packet #f _ _ PROTOCOL-UDP _ _)))
|
||||
|
||||
(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)
|
|
@ -0,0 +1,7 @@
|
|||
all:
|
||||
|
||||
run:
|
||||
raco make main.rkt && racket main.rkt
|
||||
|
||||
clean:
|
||||
find . -name compiled -type d | xargs rm -rf
|
|
@ -0,0 +1,235 @@
|
|||
#lang racket/base
|
||||
;; ARP protocol, http://tools.ietf.org/html/rfc826
|
||||
;; Only does ARP-over-ethernet.
|
||||
|
||||
(provide (struct-out arp-query)
|
||||
(struct-out arp-assertion)
|
||||
(struct-out arp-interface)
|
||||
spawn-arp-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require syndicate/monolithic)
|
||||
(require syndicate/drivers/timer)
|
||||
(require syndicate/demand-matcher)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "configuration.rkt")
|
||||
(require "ethernet.rkt")
|
||||
|
||||
(struct arp-query (protocol protocol-address interface link-address) #:prefab)
|
||||
(struct arp-assertion (protocol protocol-address interface-name) #:prefab)
|
||||
(struct arp-interface (interface-name) #:prefab)
|
||||
|
||||
(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-demand-matcher (arp-interface (?!))
|
||||
(arp-interface-up (?!))
|
||||
spawn-arp-interface))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(struct cache-key (protocol address) #:transparent)
|
||||
(struct cache-value (expiry interface address) #:transparent)
|
||||
|
||||
(struct state (cache queries assertions) #:transparent)
|
||||
|
||||
(define (spawn-arp-interface interface-name)
|
||||
(log-info "spawn-arp-interface ~v" interface-name)
|
||||
(lookup-ethernet-hwaddr (assertion (arp-interface-up interface-name))
|
||||
interface-name
|
||||
(lambda (hwaddr) (spawn-arp-interface* interface-name hwaddr))))
|
||||
|
||||
(define (spawn-arp-interface* interface-name hwaddr)
|
||||
(log-info "spawn-arp-interface* ~v ~v" interface-name hwaddr)
|
||||
(define interface (ethernet-interface interface-name hwaddr))
|
||||
|
||||
(define (expire-cache cache)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(define (not-expired? v) (< now (cache-value-expiry v)))
|
||||
(for/hash [((k v) (in-hash cache)) #:when (not-expired? v)]
|
||||
(values k v)))
|
||||
|
||||
(define timer-key (list 'arp interface-name))
|
||||
|
||||
(define (set-wakeup-alarm)
|
||||
(message (set-timer timer-key wakeup-interval 'relative)))
|
||||
|
||||
(define (compute-gestalt cache)
|
||||
(scn/union (subscription (timer-expired timer-key ?))
|
||||
(subscription interface)
|
||||
(subscription (ethernet-packet-pattern interface-name #t ARP-ethertype))
|
||||
(assertion (arp-interface-up interface-name))
|
||||
(subscription (arp-assertion ? ? interface-name))
|
||||
(subscription (observe (arp-query ? ? interface ?)))
|
||||
(for/fold [(g trie-empty)] [((k v) (in-hash cache))]
|
||||
(assertion-set-union g (assertion (arp-query (cache-key-protocol k)
|
||||
(cache-key-address k)
|
||||
(cache-value-interface v)
|
||||
(cache-value-address v)))))))
|
||||
|
||||
(define (build-packet dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
|
||||
(define hlen (bytes-length target-ha))
|
||||
(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
|
||||
#f
|
||||
hwaddr
|
||||
dest-mac
|
||||
ARP-ethertype
|
||||
packet))
|
||||
|
||||
(define (analyze-incoming-packet source destination body s)
|
||||
(bit-string-case body
|
||||
([ (= 1 :: integer bytes 2)
|
||||
(ptype :: integer bytes 2)
|
||||
hlen
|
||||
plen
|
||||
(oper :: integer bytes 2)
|
||||
(sender-hardware-address0 :: binary bytes hlen)
|
||||
(sender-protocol-address0 :: binary bytes plen)
|
||||
(target-hardware-address0 :: binary bytes hlen)
|
||||
(target-protocol-address0 :: binary bytes plen)
|
||||
(:: 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? (state-queries s) learned-key) ;; it is relevant to our interests
|
||||
(not (equal? sender-hardware-address
|
||||
(cache-value-address (hash-ref (state-cache s)
|
||||
learned-key
|
||||
(lambda ()
|
||||
(cache-value #f #f #f)))))))
|
||||
(log-info "~a ARP Adding ~a = ~a to cache"
|
||||
interface-name
|
||||
(pretty-bytes sender-protocol-address)
|
||||
(pretty-bytes sender-hardware-address)))
|
||||
(define cache (hash-set (expire-cache (state-cache s))
|
||||
learned-key
|
||||
(cache-value (+ (current-inexact-milliseconds)
|
||||
cache-entry-lifetime-msec)
|
||||
interface
|
||||
sender-hardware-address)))
|
||||
(transition (struct-copy state s [cache cache])
|
||||
(list
|
||||
(case oper
|
||||
[(1) ;; request
|
||||
(if (set-member? (state-assertions s)
|
||||
(cache-key ptype target-protocol-address))
|
||||
(begin
|
||||
(log-info "~a ARP answering request for ~a/~a"
|
||||
interface-name
|
||||
ptype
|
||||
(pretty-bytes target-protocol-address))
|
||||
(message (build-packet sender-hardware-address
|
||||
ptype
|
||||
2 ;; reply
|
||||
hwaddr
|
||||
target-protocol-address
|
||||
sender-hardware-address
|
||||
sender-protocol-address)))
|
||||
'())]
|
||||
[(2) '()] ;; reply
|
||||
[else '()])
|
||||
(compute-gestalt cache)))))
|
||||
(else #f)))
|
||||
|
||||
(define queries-projection (observe (arp-query (?!) (?!) ? ?)))
|
||||
(define (gestalt->queries g)
|
||||
(for/set [(e (in-set (trie-project/set #:take 2 g queries-projection)))]
|
||||
(match-define (list ptype pa) e)
|
||||
(cache-key ptype pa)))
|
||||
|
||||
(define assertions-projection (arp-assertion (?!) (?!) ?))
|
||||
(define (gestalt->assertions g)
|
||||
(for/set [(e (in-set (trie-project/set #:take 2 g assertions-projection)))]
|
||||
(match-define (list ptype pa) e)
|
||||
(cache-key ptype pa)))
|
||||
|
||||
(define (analyze-gestalt g s)
|
||||
(define new-assertions (gestalt->assertions g))
|
||||
(define added-assertions (set-subtract new-assertions (state-assertions s)))
|
||||
(define new-s (struct-copy state s [queries (gestalt->queries g)] [assertions new-assertions]))
|
||||
(if (trie-empty? (project-assertions g (arp-interface interface-name)))
|
||||
(quit)
|
||||
(transition new-s
|
||||
(list
|
||||
(for/list [(a (in-set added-assertions))]
|
||||
(log-info "~a ARP Announcing ~a as ~a"
|
||||
interface-name
|
||||
(pretty-bytes (cache-key-address a))
|
||||
(pretty-bytes hwaddr))
|
||||
(message (build-packet broadcast-ethernet-address
|
||||
(cache-key-protocol a)
|
||||
2 ;; reply -- gratuitous announcement
|
||||
hwaddr
|
||||
(cache-key-address a)
|
||||
hwaddr
|
||||
(cache-key-address a))))))))
|
||||
|
||||
(define (send-questions s)
|
||||
(define unanswered-queries
|
||||
(set-subtract (state-queries s) (list->set (hash-keys (state-cache s)))))
|
||||
(define (some-asserted-pa ptype)
|
||||
(match (filter (lambda (k) (equal? (cache-key-protocol k) ptype))
|
||||
(set->list (state-assertions s)))
|
||||
['() #f]
|
||||
[(list* k _) (cache-key-address k)]))
|
||||
(transition s
|
||||
(for/list [(q (in-set unanswered-queries))]
|
||||
(define pa (some-asserted-pa (cache-key-protocol q)))
|
||||
(log-info "~a ARP Asking for ~a from ~a"
|
||||
interface-name
|
||||
(pretty-bytes (cache-key-address q))
|
||||
(and pa (pretty-bytes pa)))
|
||||
(when pa
|
||||
(message (build-packet broadcast-ethernet-address
|
||||
(cache-key-protocol q)
|
||||
1 ;; request
|
||||
hwaddr
|
||||
pa
|
||||
zero-ethernet-address
|
||||
(cache-key-address q)))))))
|
||||
|
||||
(list (set-wakeup-alarm)
|
||||
(actor (lambda (e s)
|
||||
;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s)
|
||||
(match e
|
||||
[(scn g)
|
||||
(sequence-transitions (analyze-gestalt g s)
|
||||
send-questions)]
|
||||
[(message (ethernet-packet _ _ source destination _ body))
|
||||
(analyze-incoming-packet source destination body s)]
|
||||
[(message (timer-expired _ _))
|
||||
(define new-s (struct-copy state s
|
||||
[cache (expire-cache (state-cache s))]))
|
||||
(sequence-transitions (transition new-s
|
||||
(list (set-wakeup-alarm)
|
||||
(compute-gestalt (state-cache new-s))))
|
||||
send-questions)]
|
||||
[_ #f]))
|
||||
(state (hash) (set) (set))
|
||||
(compute-gestalt (hash)))))
|
|
@ -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))
|
|
@ -0,0 +1,21 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out ethernet-interface)
|
||||
(struct-out host-route)
|
||||
(struct-out gateway-route)
|
||||
(struct-out net-route)
|
||||
|
||||
(struct-out route-up))
|
||||
|
||||
(struct ethernet-interface (name hwaddr) #:prefab)
|
||||
|
||||
;; 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
|
|
@ -0,0 +1,26 @@
|
|||
#lang racket/base
|
||||
;; Demonstration stack configuration for various hosts.
|
||||
|
||||
(require racket/match)
|
||||
(require syndicate/monolithic)
|
||||
(require (only-in mzlib/os gethostname))
|
||||
(require (only-in racket/string string-split))
|
||||
(require "configuration.rkt")
|
||||
|
||||
(provide spawn-demo-config)
|
||||
|
||||
(define (spawn-demo-config)
|
||||
(actor (lambda (e s) #f)
|
||||
(void)
|
||||
(match (gethostname)
|
||||
["stockholm.ccs.neu.edu"
|
||||
(scn/union (assertion (host-route (bytes 129 10 115 94) 24 "eth0"))
|
||||
(assertion (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"]))
|
||||
(scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
|
||||
(assertion (host-route (bytes 192 168 1 222) 24 interface)))])))
|
|
@ -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))
|
|
@ -0,0 +1,134 @@
|
|||
#lang racket/base
|
||||
;; Ethernet driver
|
||||
|
||||
(provide (struct-out ethernet-packet)
|
||||
zero-ethernet-address
|
||||
broadcast-ethernet-address
|
||||
interface-names
|
||||
spawn-ethernet-driver
|
||||
ethernet-packet-pattern
|
||||
lookup-ethernet-hwaddr)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/async-channel)
|
||||
|
||||
(require syndicate/monolithic)
|
||||
(require syndicate/demand-matcher)
|
||||
(require "on-claim.rkt")
|
||||
|
||||
(require packet-socket)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "configuration.rkt")
|
||||
(require "dump-bytes.rkt")
|
||||
|
||||
(struct ethernet-packet (interface from-wire? source destination ethertype body) #:prefab)
|
||||
|
||||
(define zero-ethernet-address (bytes 0 0 0 0 0 0))
|
||||
(define broadcast-ethernet-address (bytes 255 255 255 255 255 255))
|
||||
|
||||
(define interface-names (raw-interface-names))
|
||||
(log-info "Device names: ~a" interface-names)
|
||||
|
||||
(define (spawn-ethernet-driver)
|
||||
(spawn-demand-matcher (observe (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?))
|
||||
(ethernet-interface (?!) ?)
|
||||
spawn-interface-tap))
|
||||
|
||||
(define (spawn-interface-tap interface-name)
|
||||
(define h (raw-interface-open interface-name))
|
||||
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
|
||||
(cond
|
||||
[(not h)
|
||||
(log-error "ethernet: Couldn't open interface ~v" interface-name)
|
||||
'()]
|
||||
[else
|
||||
(log-info "Opened interface ~a, yielding handle ~v" interface-name h)
|
||||
(define control-ch (make-async-channel))
|
||||
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
|
||||
(actor (lambda (e h)
|
||||
(match e
|
||||
[(scn g)
|
||||
(if (trie-empty? g)
|
||||
(begin (async-channel-put control-ch 'quit)
|
||||
(quit))
|
||||
(begin (async-channel-put control-ch 'unblock)
|
||||
#f))]
|
||||
[(message (inbound (? ethernet-packet? p)))
|
||||
;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
|
||||
;; (ethernet-interface-name (ethernet-packet-interface p))
|
||||
;; (pretty-bytes (ethernet-packet-source p))
|
||||
;; (pretty-bytes (ethernet-packet-destination p))
|
||||
;; (number->string (ethernet-packet-ethertype p) 16))
|
||||
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
|
||||
(transition h (message p))]
|
||||
[(message (? ethernet-packet? p))
|
||||
;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
|
||||
;; (ethernet-interface-name (ethernet-packet-interface p))
|
||||
;; (pretty-bytes (ethernet-packet-source p))
|
||||
;; (pretty-bytes (ethernet-packet-destination p))
|
||||
;; (number->string (ethernet-packet-ethertype p) 16))
|
||||
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
|
||||
(raw-interface-write h (encode-ethernet-packet p))
|
||||
#f]
|
||||
[_ #f]))
|
||||
h
|
||||
(scn/union (assertion interface)
|
||||
(subscription (ethernet-packet interface #f ? ? ? ?))
|
||||
(subscription (observe (ethernet-packet interface #t ? ? ? ?)))
|
||||
(subscription (inbound (ethernet-packet interface #t ? ? ? ?)))))]))
|
||||
|
||||
(define (interface-packet-read-loop interface h control-ch)
|
||||
(define (blocked)
|
||||
(match (async-channel-get control-ch)
|
||||
['unblock (unblocked)]
|
||||
['quit (void)]))
|
||||
(define (unblocked)
|
||||
(match (async-channel-try-get control-ch)
|
||||
['unblock (unblocked)]
|
||||
['quit (void)]
|
||||
[#f
|
||||
(define p (raw-interface-read h))
|
||||
(define decoded (decode-ethernet-packet interface p))
|
||||
(when decoded (send-ground-message decoded))
|
||||
(unblocked)]))
|
||||
(blocked)
|
||||
(raw-interface-close h))
|
||||
|
||||
(define (decode-ethernet-packet interface p)
|
||||
(bit-string-case p
|
||||
([ (destination :: binary bytes 6)
|
||||
(source :: binary bytes 6)
|
||||
(ethertype :: integer bytes 2)
|
||||
(body :: binary) ]
|
||||
(ethernet-packet interface
|
||||
#t
|
||||
(bit-string->bytes source)
|
||||
(bit-string->bytes destination)
|
||||
ethertype
|
||||
(bit-string->bytes body)))
|
||||
(else #f)))
|
||||
|
||||
(define (encode-ethernet-packet p)
|
||||
(match-define (ethernet-packet _ _ source destination ethertype body) p)
|
||||
(bit-string->bytes
|
||||
(bit-string (destination :: binary bytes 6)
|
||||
(source :: binary bytes 6)
|
||||
(ethertype :: integer bytes 2)
|
||||
(body :: binary))))
|
||||
|
||||
(define (ethernet-packet-pattern interface-name from-wire? ethertype)
|
||||
(ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?))
|
||||
|
||||
(define (lookup-ethernet-hwaddr base-interests interface-name k)
|
||||
(on-claim #:timeout-msec 5000
|
||||
#:on-timeout (lambda ()
|
||||
(log-info "Lookup of ethernet interface ~v failed" interface-name)
|
||||
'())
|
||||
(lambda (_g hwaddrss)
|
||||
(and (not (set-empty? hwaddrss))
|
||||
(let ((hwaddr (car (set-first hwaddrss))))
|
||||
(k hwaddr))))
|
||||
base-interests
|
||||
(ethernet-interface interface-name (?!))))
|
|
@ -0,0 +1,48 @@
|
|||
#lang syndicate/monolithic
|
||||
|
||||
(require syndicate/drivers/timer)
|
||||
(require "demo-config.rkt")
|
||||
(require "ethernet.rkt")
|
||||
(require "arp.rkt")
|
||||
(require "ip.rkt")
|
||||
(require "tcp.rkt")
|
||||
(require "udp.rkt")
|
||||
|
||||
;;(log-events-and-actions? #t)
|
||||
|
||||
(spawn-timer-driver)
|
||||
(spawn-ethernet-driver)
|
||||
(spawn-arp-driver)
|
||||
(spawn-ip-driver)
|
||||
(spawn-tcp-driver)
|
||||
(spawn-udp-driver)
|
||||
(spawn-demo-config)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(let ()
|
||||
(define local-handle (tcp-handle 'httpclient))
|
||||
(define remote-handle (tcp-address "129.10.115.92" 80))
|
||||
|
||||
(spawn (lambda (e seen-peer?)
|
||||
(match e
|
||||
[(scn g)
|
||||
(define peer-present? (trie-non-empty? g))
|
||||
(if (and (not peer-present?) seen-peer?)
|
||||
(begin (printf "URL fetcher exiting.\n")
|
||||
(quit))
|
||||
(transition (or seen-peer? peer-present?)
|
||||
(message
|
||||
(tcp-channel
|
||||
local-handle
|
||||
remote-handle
|
||||
#"GET / HTTP/1.0\r\nHost: stockholm.ccs.neu.edu\r\n\r\n"))))]
|
||||
[(message (tcp-channel _ _ bs))
|
||||
(printf "----------------------------------------\n~a\n" bs)
|
||||
(printf "----------------------------------------\n")
|
||||
#f]
|
||||
[_ #f]))
|
||||
#f
|
||||
(scn/union (advertisement (tcp-channel local-handle remote-handle ?))
|
||||
(subscription (tcp-channel remote-handle local-handle ?))
|
||||
(subscription (advertise (tcp-channel remote-handle local-handle ?))))))
|
|
@ -0,0 +1,328 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out ip-packet)
|
||||
ip-address->hostname
|
||||
ip-string->ip-address
|
||||
apply-netmask
|
||||
ip-address-in-subnet?
|
||||
gestalt->local-ip-addresses
|
||||
observe-local-ip-addresses-gestalt
|
||||
broadcast-ip-address
|
||||
spawn-ip-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require (only-in racket/string string-split))
|
||||
(require syndicate/monolithic)
|
||||
(require syndicate/drivers/timer)
|
||||
(require syndicate/demand-matcher)
|
||||
(require syndicate/protocol/advertise)
|
||||
(require bitsyntax)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
(require "configuration.rkt")
|
||||
(require "checksum.rkt")
|
||||
(require "ethernet.rkt")
|
||||
(require "arp.rkt")
|
||||
(require "on-claim.rkt")
|
||||
|
||||
(struct ip-packet (source-interface ;; string for an ethernet interface, or #f for local interfaces
|
||||
source
|
||||
destination
|
||||
protocol
|
||||
options
|
||||
body)
|
||||
#:prefab) ;; TODO: more fields
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (ip-address->hostname bs)
|
||||
(bit-string-case bs
|
||||
([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
|
||||
|
||||
(define (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 local-ip-address-projector (host-route (?!) ? ?))
|
||||
(define (gestalt->local-ip-addresses g) (trie-project/set/single g local-ip-address-projector))
|
||||
(define observe-local-ip-addresses-gestalt (subscription (host-route ? ? ?)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (spawn-ip-driver)
|
||||
(list
|
||||
(spawn-demand-matcher (host-route (?!) (?!) (?!))
|
||||
(route-up (host-route (?!) (?!) (?!)))
|
||||
spawn-host-route)
|
||||
(spawn-demand-matcher (gateway-route (?!) (?!) (?!) (?!))
|
||||
(route-up (gateway-route (?!) (?!) (?!) (?!)))
|
||||
spawn-gateway-route)
|
||||
(spawn-demand-matcher (net-route (?!) (?!) (?!))
|
||||
(route-up (net-route (?!) (?!) (?!)))
|
||||
spawn-net-route)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Local IP route
|
||||
|
||||
(define (spawn-host-route my-address netmask interface-name)
|
||||
(list
|
||||
(let ((network-addr (apply-netmask my-address netmask)))
|
||||
(spawn-normal-ip-route (host-route my-address netmask interface-name)
|
||||
network-addr
|
||||
netmask
|
||||
interface-name))
|
||||
(actor (lambda (e s)
|
||||
(match e
|
||||
[(scn (? trie-empty?)) (quit)]
|
||||
[(message (ip-packet _ peer-address _ _ _ body))
|
||||
(bit-string-case body
|
||||
([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
|
||||
(case type
|
||||
[(8) ;; ECHO (0 is ECHO-REPLY)
|
||||
(log-info "Ping of ~a from ~a"
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address))
|
||||
(define reply-data0 (bit-string 0
|
||||
code
|
||||
(0 :: integer bytes 2) ;; TODO
|
||||
(rest :: binary)))
|
||||
(transition s (message (ip-packet #f
|
||||
my-address
|
||||
peer-address
|
||||
PROTOCOL-ICMP
|
||||
#""
|
||||
(ip-checksum 2 reply-data0))))]
|
||||
[else
|
||||
(log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
|
||||
type
|
||||
code
|
||||
checksum
|
||||
(pretty-bytes my-address)
|
||||
(pretty-bytes peer-address)
|
||||
(dump-bytes->string rest))
|
||||
#f]))
|
||||
(else #f))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(scn/union (advertisement (ip-packet ? my-address ? PROTOCOL-ICMP ? ?))
|
||||
(subscription (ip-packet ? ? my-address PROTOCOL-ICMP ? ?))
|
||||
(assertion (arp-assertion IPv4-ethertype my-address interface-name))
|
||||
(subscription (host-route my-address netmask interface-name))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Gateway IP route
|
||||
|
||||
(struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent)
|
||||
|
||||
(define (spawn-gateway-route network netmask gateway-addr interface-name)
|
||||
(define the-route (gateway-route network netmask gateway-addr interface-name))
|
||||
|
||||
(define host-route-projector (host-route (?!) (?!) ?))
|
||||
(define gateway-route-projector (gateway-route (?!) (?!) ? ?))
|
||||
(define net-route-projector (net-route (?!) (?!) ?))
|
||||
(define gateway-arp-projector (arp-query IPv4-ethertype
|
||||
gateway-addr
|
||||
(?! (ethernet-interface interface-name ?))
|
||||
(?!)))
|
||||
|
||||
(define (covered-by-some-other-route? addr routes)
|
||||
(for/or ([r (in-set routes)])
|
||||
(match-define (list net msk) r)
|
||||
(and (positive? msk)
|
||||
(ip-address-in-subnet? addr net msk))))
|
||||
|
||||
(actor (lambda (e s)
|
||||
(match e
|
||||
[(scn g)
|
||||
(define host-ips+netmasks (trie-project/set #:take 2 g host-route-projector))
|
||||
(define gw-nets+netmasks (trie-project/set #:take 2 g gateway-route-projector))
|
||||
(define net-nets+netmasks (trie-project/set #:take 2 g net-route-projector))
|
||||
(define gw-ip+hwaddr
|
||||
(let ((vs (trie-project/set #:take 2 g gateway-arp-projector)))
|
||||
(and vs (not (set-empty? vs)) (set-first vs))))
|
||||
(when (and gw-ip+hwaddr (not (gateway-route-state-gateway-hwaddr s)))
|
||||
(log-info "Discovered gateway ~a at ~a on interface ~a."
|
||||
(ip-address->hostname gateway-addr)
|
||||
(ethernet-interface-name (car gw-ip+hwaddr))
|
||||
(pretty-bytes (cadr gw-ip+hwaddr))))
|
||||
(if (trie-empty? (project-assertions g (?! the-route)))
|
||||
(quit)
|
||||
(transition (gateway-route-state
|
||||
(set-union host-ips+netmasks
|
||||
gw-nets+netmasks
|
||||
net-nets+netmasks)
|
||||
(and gw-ip+hwaddr (car gw-ip+hwaddr))
|
||||
(and gw-ip+hwaddr (cadr gw-ip+hwaddr)))
|
||||
'()))]
|
||||
[(message (? ip-packet? p))
|
||||
(define gw-if (gateway-route-state-gateway-interface s))
|
||||
(when (not gw-if)
|
||||
(log-warning "Gateway hwaddr for ~a not known, packet dropped."
|
||||
(ip-address->hostname gateway-addr)))
|
||||
(and gw-if
|
||||
(not (equal? (ip-packet-source-interface p) (ethernet-interface-name gw-if)))
|
||||
(not (covered-by-some-other-route? (ip-packet-destination p)
|
||||
(gateway-route-state-routes s)))
|
||||
(transition s
|
||||
(message (ethernet-packet gw-if
|
||||
#f
|
||||
(ethernet-interface-hwaddr gw-if)
|
||||
(gateway-route-state-gateway-hwaddr s)
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p)))))]
|
||||
[_ #f]))
|
||||
(gateway-route-state (set) #f #f)
|
||||
(scn/union (subscription the-route)
|
||||
(assertion (route-up the-route))
|
||||
(subscription (ip-packet ? ? ? ? ? ?))
|
||||
observe-local-ip-addresses-gestalt
|
||||
(subscription (net-route ? ? ?))
|
||||
(subscription (gateway-route ? ? ? ?))
|
||||
(subscription (projection->pattern gateway-arp-projector)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; General net route
|
||||
|
||||
(define (spawn-net-route network-addr netmask link)
|
||||
(spawn-normal-ip-route (net-route network-addr netmask link) network-addr netmask link))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Normal IP route
|
||||
|
||||
(define (spawn-normal-ip-route the-route network netmask interface-name)
|
||||
(actor (lambda (e s)
|
||||
(match e
|
||||
[(scn (? trie-empty?)) (quit)]
|
||||
[(message (ethernet-packet _ _ _ _ _ body))
|
||||
(define p (parse-ip-packet interface-name body))
|
||||
(and p (transition s (message p)))]
|
||||
[(message (? ip-packet? p))
|
||||
(define destination (ip-packet-destination p))
|
||||
(and (not (equal? (ip-packet-source-interface p) interface-name))
|
||||
(ip-address-in-subnet? destination network netmask)
|
||||
(transition
|
||||
s
|
||||
(lookup-arp destination
|
||||
(ethernet-interface interface-name ?)
|
||||
trie-empty
|
||||
(lambda (interface destination-hwaddr)
|
||||
(message (ethernet-packet interface
|
||||
#f
|
||||
(ethernet-interface-hwaddr interface)
|
||||
destination-hwaddr
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p)))))))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(scn/union (subscription the-route)
|
||||
(assertion (route-up the-route))
|
||||
(subscription (ethernet-packet-pattern interface-name #t IPv4-ethertype))
|
||||
(assertion (arp-interface interface-name))
|
||||
(subscription (ip-packet ? ? ? ? ? ?)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(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)
|
||||
|
||||
(define (lookup-arp ipaddr query-interface-pattern base-gestalt k)
|
||||
(on-claim #:name (string->symbol (format "lookup-arp:~a" (ip-address->hostname ipaddr)))
|
||||
(lambda (_g arp-results)
|
||||
(if (not arp-results)
|
||||
(error 'ip "Someone has published a wildcard arp result")
|
||||
(and (not (set-empty? arp-results))
|
||||
(match (set-first arp-results)
|
||||
[(list interface hwaddr)
|
||||
(log-info "ARP lookup yielded ~a on ~a for ~a"
|
||||
(pretty-bytes hwaddr)
|
||||
(ethernet-interface-name interface)
|
||||
(ip-address->hostname ipaddr))
|
||||
(when (> (set-count arp-results) 1)
|
||||
(log-warning "Ambiguous ARP result for ~a: ~v"
|
||||
(ip-address->hostname ipaddr)
|
||||
arp-results))
|
||||
(k interface hwaddr)]))))
|
||||
base-gestalt
|
||||
(arp-query IPv4-ethertype ipaddr (?! query-interface-pattern) (?!))
|
||||
#:timeout-msec 5000
|
||||
#:on-timeout (lambda ()
|
||||
(log-warning "ARP lookup of ~a failed, packet dropped"
|
||||
(ip-address->hostname ipaddr))
|
||||
'())))
|
|
@ -0,0 +1,121 @@
|
|||
#lang syndicate/monolithic
|
||||
|
||||
(require syndicate/demand-matcher)
|
||||
(require syndicate/drivers/timer)
|
||||
(require syndicate/protocol/advertise)
|
||||
(require "demo-config.rkt")
|
||||
(require "ethernet.rkt")
|
||||
(require "arp.rkt")
|
||||
(require "ip.rkt")
|
||||
(require "tcp.rkt")
|
||||
(require "udp.rkt")
|
||||
|
||||
;;(log-events-and-actions? #t)
|
||||
|
||||
(spawn-timer-driver)
|
||||
(spawn-ethernet-driver)
|
||||
(spawn-arp-driver)
|
||||
(spawn-ip-driver)
|
||||
(spawn-tcp-driver)
|
||||
(spawn-udp-driver)
|
||||
(spawn-demo-config)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(let ()
|
||||
(local-require racket/set racket/string)
|
||||
|
||||
(define (spawn-session them us)
|
||||
(define user (gensym 'user))
|
||||
(define remote-detector (inbound (?!)))
|
||||
(define peer-detector (advertise `(,(?!) says ,?)))
|
||||
(define (send-to-remote fmt . vs)
|
||||
(message (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
|
||||
(define (say who fmt . vs)
|
||||
(unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
(list (send-to-remote "Welcome, ~a.\n" user)
|
||||
(actor
|
||||
(lambda (e peers)
|
||||
(match e
|
||||
[(message (inbound (tcp-channel _ _ bs)))
|
||||
(transition peers (message `(,user says ,(string-trim (bytes->string/utf-8 bs)))))]
|
||||
[(message `(,who says ,what))
|
||||
(transition peers (say who "says: ~a" what))]
|
||||
[(scn assertions)
|
||||
(if (trie-empty? (trie-project assertions remote-detector))
|
||||
(quit (send-to-remote "Goodbye!\n"))
|
||||
(let ((new-peers (trie-project/set/single assertions peer-detector)))
|
||||
(define arrived (set-subtract new-peers peers))
|
||||
(define departed (set-subtract peers new-peers))
|
||||
(transition new-peers
|
||||
(list (for/list [(who arrived)] (say who "arrived."))
|
||||
(for/list [(who departed)] (say who "departed."))))))]
|
||||
[#f #f]))
|
||||
(set)
|
||||
(scn/union
|
||||
(subscription `(,? says ,?)) ;; read actual chat messages
|
||||
(subscription (advertise `(,? says ,?))) ;; observe peer presence
|
||||
(advertisement `(,user says ,?)) ;; advertise our presence
|
||||
(subscription (inbound (tcp-channel them us ?))) ;; read from remote client
|
||||
(subscription (inbound (advertise (tcp-channel them us ?)))) ;; monitor remote client
|
||||
(advertisement (inbound (tcp-channel us them ?))) ;; we will write to remote client
|
||||
))))
|
||||
|
||||
(dataspace-actor
|
||||
(spawn-demand-matcher (inbound (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?)))
|
||||
(inbound (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?)))
|
||||
spawn-session))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(actor (lambda (e s)
|
||||
(match e
|
||||
[(message (udp-packet src dst body))
|
||||
(log-info "Got packet from ~v: ~v" src body)
|
||||
(transition s (message
|
||||
(udp-packet dst
|
||||
src
|
||||
(string->bytes/utf-8 (format "You said: ~a" body)))))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(scn (subscription (udp-packet ? (udp-listener 6667) ?)))))
|
||||
|
||||
(let ()
|
||||
(define (spawn-session them us)
|
||||
(list
|
||||
(message 'bump)
|
||||
(actor (lambda (e s)
|
||||
(match e
|
||||
[(message `(counter ,counter))
|
||||
(define response
|
||||
(string->bytes/utf-8
|
||||
(format (string-append
|
||||
"HTTP/1.0 200 OK\r\n\r\n"
|
||||
"<h1>Hello world from syndicate-monolithic-netstack!</h1>\n"
|
||||
"<p>This is running on syndicate-monolithic'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>")
|
||||
counter)))
|
||||
(quit (message (outbound (tcp-channel us them response))))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(scn/union (subscription `(counter ,?))
|
||||
(subscription (inbound (tcp-channel them us ?)))
|
||||
(subscription (inbound (advertise (tcp-channel them us ?))))
|
||||
(advertisement (inbound (tcp-channel us them ?)))))))
|
||||
|
||||
(dataspace-actor
|
||||
(actor (lambda (e counter)
|
||||
(match e
|
||||
[(message 'bump)
|
||||
(transition (+ counter 1) (message `(counter ,counter)))]
|
||||
[_ #f]))
|
||||
0
|
||||
(scn (subscription 'bump)))
|
||||
(spawn-demand-matcher
|
||||
(inbound (advertise (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?)))
|
||||
(inbound (observe (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?)))
|
||||
spawn-session))
|
||||
|
||||
)
|
|
@ -0,0 +1,47 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide on-claim)
|
||||
|
||||
(require syndicate/monolithic)
|
||||
(require syndicate/drivers/timer)
|
||||
|
||||
;; (Trie (Option (Setof (Listof Value))) ... -> (Option (Constreeof Action)))
|
||||
;; Trie Projection ...
|
||||
;; -> Action
|
||||
;; Spawns a process that observes the given projections. Any time the
|
||||
;; environment's interests change in a relevant way, calls
|
||||
;; check-and-maybe-actor-fn with the aggregate interests and the
|
||||
;; projection results. If check-and-maybe-actor-fn returns #f,
|
||||
;; continues to wait; otherwise, takes the action(s) returned, and
|
||||
;; quits.
|
||||
(define (on-claim #:timeout-msec [timeout-msec #f]
|
||||
#:on-timeout [timeout-handler (lambda () '())]
|
||||
#:name [name #f]
|
||||
check-and-maybe-actor-fn
|
||||
base-interests
|
||||
. projections)
|
||||
(define timer-id (gensym 'on-claim))
|
||||
(define (on-claim-handler e state)
|
||||
(match e
|
||||
[(scn new-aggregate)
|
||||
(define projection-results
|
||||
(map (lambda (p) (trie-project/set #:take (projection-arity p) new-aggregate p))
|
||||
projections))
|
||||
(define maybe-actor (apply check-and-maybe-actor-fn
|
||||
new-aggregate
|
||||
projection-results))
|
||||
(if maybe-actor
|
||||
(quit maybe-actor)
|
||||
#f)]
|
||||
[(message (timer-expired (== timer-id) _))
|
||||
(quit (timeout-handler))]
|
||||
[_ #f]))
|
||||
(list
|
||||
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
|
||||
(actor #:name name
|
||||
on-claim-handler
|
||||
(void)
|
||||
(scn/union base-interests
|
||||
(assertion-set-union*
|
||||
(map (lambda (p) (subscription (projection->pattern p))) projections))
|
||||
(subscription (timer-expired timer-id ?))))))
|
|
@ -0,0 +1,38 @@
|
|||
#lang racket/base
|
||||
;; UDP/TCP port allocator
|
||||
|
||||
(provide spawn-port-allocator
|
||||
(struct-out port-allocation-request))
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require syndicate/monolithic)
|
||||
(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 observer-gestalt compute-used-ports)
|
||||
(actor #:name (string->symbol (format "port-allocator:~a" allocator-type))
|
||||
(lambda (e s)
|
||||
(match e
|
||||
[(scn g)
|
||||
(define local-ips (or (gestalt->local-ip-addresses g) (set)))
|
||||
(define new-used-ports (compute-used-ports g local-ips))
|
||||
(log-info "port-allocator ~v used ports: ~v" allocator-type new-used-ports)
|
||||
(transition (port-allocator-state new-used-ports local-ips) '())]
|
||||
[(message (port-allocation-request _ k))
|
||||
(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))
|
||||
(scn/union (subscription (port-allocation-request allocator-type ?))
|
||||
observe-local-ip-addresses-gestalt
|
||||
observer-gestalt)))
|
|
@ -0,0 +1,666 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out tcp-address)
|
||||
(struct-out tcp-handle)
|
||||
(struct-out tcp-listener)
|
||||
(struct-out tcp-channel)
|
||||
spawn-tcp-driver)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require syndicate/monolithic)
|
||||
(require syndicate/drivers/timer)
|
||||
(require syndicate/demand-matcher)
|
||||
(require syndicate/protocol/advertise)
|
||||
(require bitsyntax)
|
||||
|
||||
(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
|
||||
;; tcp-listener/tcp-address : "user" inbound connections
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Protocol messages
|
||||
|
||||
(struct tcp-address (host port) #:prefab)
|
||||
(struct tcp-handle (id) #:prefab)
|
||||
(struct tcp-listener (port) #:prefab)
|
||||
|
||||
(struct tcp-channel (source destination subpacket) #:prefab)
|
||||
|
||||
(struct tcp-packet (from-wire?
|
||||
source-ip
|
||||
source-port
|
||||
destination-ip
|
||||
destination-port
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size
|
||||
options
|
||||
data)
|
||||
#:prefab)
|
||||
|
||||
;; (tcp-port-allocation Number (U TcpHandle TcpListener))
|
||||
(struct tcp-port-allocation (port handle) #:prefab)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; User-accessible driver startup
|
||||
|
||||
(define (spawn-tcp-driver)
|
||||
(list (spawn-demand-matcher #:name 'tcp-inbound-driver
|
||||
(advertise (observe (tcp-channel ? (?! (tcp-listener ?)) ?)))
|
||||
(advertise (advertise (tcp-channel ? (?! (tcp-listener ?)) ?)))
|
||||
(lambda (server-addr)
|
||||
(match-define (tcp-listener port) server-addr)
|
||||
;; TODO: have listener shut down once user-level listener does
|
||||
(list
|
||||
(actor #:name (string->symbol
|
||||
(format "tcp-listener-port-reservation:~a" port))
|
||||
(lambda (e s) #f)
|
||||
(void)
|
||||
(scn (assertion (tcp-port-allocation port server-addr))))
|
||||
(spawn-demand-matcher
|
||||
#:name (string->symbol (format "tcp-listener:~a" port))
|
||||
(advertise (tcp-channel (?! (tcp-address ? ?))
|
||||
(?! (tcp-address ? port))
|
||||
?))
|
||||
(observe (tcp-channel (?! (tcp-address ? ?))
|
||||
(?! (tcp-address ? port))
|
||||
?))
|
||||
(spawn-relay server-addr)))))
|
||||
(spawn-demand-matcher #:name 'tcp-outbound-driver
|
||||
(advertise (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?))
|
||||
(observe (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?))
|
||||
allocate-port-and-spawn-socket)
|
||||
(spawn-tcp-port-allocator)
|
||||
(spawn-kernel-tcp-driver)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Port allocation
|
||||
|
||||
(define (spawn-tcp-port-allocator)
|
||||
(spawn-port-allocator 'tcp
|
||||
(subscription (tcp-port-allocation ? ?))
|
||||
(lambda (g local-ips)
|
||||
(project-assertions g (tcp-port-allocation (?!) ?)))))
|
||||
|
||||
(define (allocate-port-and-spawn-socket local-addr remote-addr)
|
||||
(message (port-allocation-request
|
||||
'tcp
|
||||
(lambda (port local-ips)
|
||||
;; TODO: Choose a sensible IP address for the outbound
|
||||
;; connection. We don't have enough information to do this
|
||||
;; well at the moment, so just pick some available local IP
|
||||
;; address.
|
||||
;;
|
||||
;; Interesting note: In some sense, the right answer is
|
||||
;; "?". This would give us a form of mobility, where IP
|
||||
;; addresses only route to a given bucket-of-state and ONLY
|
||||
;; the port number selects a substate therein. That's not
|
||||
;; how TCP is defined however so we can't do that.
|
||||
(define appropriate-ip (set-first local-ips))
|
||||
(define appropriate-host (ip-address->hostname appropriate-ip))
|
||||
(match-define (tcp-address remote-host remote-port) remote-addr)
|
||||
(define remote-ip (ip-string->ip-address remote-host))
|
||||
(list
|
||||
((spawn-relay local-addr) remote-addr (tcp-address appropriate-host port))
|
||||
(spawn-state-vector remote-ip remote-port appropriate-ip port))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Relay between kernel-level and user-level
|
||||
|
||||
(define relay-peer-wait-time-msec 5000)
|
||||
|
||||
(define ((spawn-relay local-user-addr) remote-addr local-tcp-addr)
|
||||
(define timer-name (list 'spawn-relay local-tcp-addr remote-addr))
|
||||
(define local-peer-traffic (?! (observe (tcp-channel remote-addr local-user-addr ?))))
|
||||
(define remote-peer-traffic (?! (advertise (tcp-channel remote-addr local-tcp-addr ?))))
|
||||
(list
|
||||
(message (set-timer timer-name relay-peer-wait-time-msec 'relative))
|
||||
(actor #:name (string->symbol (format "tcp-relay:~v:~v:~v"
|
||||
local-user-addr
|
||||
remote-addr
|
||||
local-tcp-addr))
|
||||
(lambda (e state)
|
||||
(match e
|
||||
[(scn g)
|
||||
(define local-peer-absent? (trie-empty? (trie-project g local-peer-traffic)))
|
||||
(define remote-peer-absent? (trie-empty? (trie-project g remote-peer-traffic)))
|
||||
(define new-state (+ (if local-peer-absent? 0 1) (if remote-peer-absent? 0 1)))
|
||||
(if (< new-state state)
|
||||
(quit)
|
||||
(transition new-state '()))]
|
||||
[(message (tcp-channel (== local-user-addr) (== remote-addr) bs))
|
||||
(transition state (message (tcp-channel local-tcp-addr remote-addr bs)))]
|
||||
[(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs))
|
||||
(transition state (message (tcp-channel remote-addr local-user-addr bs)))]
|
||||
[(message (timer-expired _ _))
|
||||
#:when (< state 2) ;; we only care if we're not fully connected
|
||||
(error 'spawn-relay "TCP relay process timed out waiting for peer")]
|
||||
[_ #f]))
|
||||
0
|
||||
(scn/union (subscription (projection->pattern local-peer-traffic))
|
||||
(subscription (projection->pattern remote-peer-traffic))
|
||||
(assertion (tcp-port-allocation (tcp-address-port local-tcp-addr)
|
||||
local-user-addr))
|
||||
(subscription (tcp-channel remote-addr local-tcp-addr ?))
|
||||
(subscription (tcp-channel local-user-addr remote-addr ?))
|
||||
(advertisement (tcp-channel remote-addr local-user-addr ?))
|
||||
(advertisement (tcp-channel local-tcp-addr remote-addr ?))
|
||||
(subscription (timer-expired timer-name ?))))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Codec & kernel-level driver
|
||||
|
||||
(define PROTOCOL-TCP 6)
|
||||
|
||||
(struct codec-state (local-ips active-state-vectors) #:transparent)
|
||||
|
||||
(define (spawn-kernel-tcp-driver)
|
||||
|
||||
(define (state-vector-active? statevec s)
|
||||
(set-member? (codec-state-active-state-vectors s) statevec))
|
||||
|
||||
(define (analyze-incoming-packet src-ip dst-ip body s)
|
||||
(bit-string-case body
|
||||
([ (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
(sequence-number :: integer bytes 4)
|
||||
(ack-number :: integer bytes 4)
|
||||
(data-offset :: integer bits 4)
|
||||
(reserved :: integer bits 3)
|
||||
(ns :: integer bits 1)
|
||||
(cwr :: integer bits 1)
|
||||
(ece :: integer bits 1)
|
||||
(urg :: integer bits 1)
|
||||
(ack :: integer bits 1)
|
||||
(psh :: integer bits 1)
|
||||
(rst :: integer bits 1)
|
||||
(syn :: integer bits 1)
|
||||
(fin :: integer bits 1)
|
||||
(window-size :: integer bytes 2)
|
||||
(checksum :: integer bytes 2) ;; TODO: check checksum
|
||||
(urgent-pointer :: integer bytes 2)
|
||||
(rest :: binary) ]
|
||||
(let* ((flags (set))
|
||||
(statevec (list src-ip src-port dst-ip dst-port))
|
||||
(old-active-state-vectors (codec-state-active-state-vectors s))
|
||||
(spawn-needed? (and (not (state-vector-active? statevec s))
|
||||
(zero? rst)))) ;; don't bother spawning if it's a rst
|
||||
(define-syntax-rule (set-flags! v ...)
|
||||
(begin (unless (zero? v) (set! flags (set-add flags 'v))) ...))
|
||||
(set-flags! ns cwr ece urg ack psh rst syn fin)
|
||||
(log-info "TCP ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a)"
|
||||
(ip-address->hostname src-ip)
|
||||
src-port
|
||||
(ip-address->hostname dst-ip)
|
||||
dst-port
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size)
|
||||
(when spawn-needed? (log-info " - spawn needed!"))
|
||||
(bit-string-case rest
|
||||
([ (opts :: binary bytes (- (* data-offset 4) 20))
|
||||
(data :: binary) ]
|
||||
(let ((packet (tcp-packet #t
|
||||
src-ip
|
||||
src-port
|
||||
dst-ip
|
||||
dst-port
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size
|
||||
(bit-string->bytes opts)
|
||||
(bit-string->bytes data))))
|
||||
(transition (if spawn-needed?
|
||||
(struct-copy codec-state s
|
||||
[active-state-vectors
|
||||
(set-add old-active-state-vectors statevec)])
|
||||
s)
|
||||
(list
|
||||
(when spawn-needed? (spawn-state-vector src-ip src-port
|
||||
dst-ip dst-port))
|
||||
;; TODO: get packet to the new state-vector process somehow
|
||||
(message packet)))))
|
||||
(else #f))))
|
||||
(else #f)))
|
||||
|
||||
(define statevec-projection (observe (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?)))
|
||||
|
||||
(define (analyze-gestalt g s)
|
||||
(define local-ips (gestalt->local-ip-addresses g))
|
||||
(define statevecs (trie-project/set #:take 4 g statevec-projection))
|
||||
(log-info "gestalt yielded statevecs ~v and local-ips ~v" statevecs local-ips)
|
||||
(transition (struct-copy codec-state s
|
||||
[local-ips local-ips]
|
||||
[active-state-vectors statevecs]) '()))
|
||||
|
||||
(define (deliver-outbound-packet p s)
|
||||
(match-define (tcp-packet #f
|
||||
src-ip
|
||||
src-port
|
||||
dst-ip
|
||||
dst-port
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size
|
||||
options
|
||||
data)
|
||||
p)
|
||||
(log-info "TCP ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a)"
|
||||
(ip-address->hostname src-ip)
|
||||
src-port
|
||||
(ip-address->hostname dst-ip)
|
||||
dst-port
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size)
|
||||
(define (flag-bit sym) (if (set-member? flags sym) 1 0))
|
||||
(define payload (bit-string (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
(sequence-number :: integer bytes 4)
|
||||
(ack-number :: integer bytes 4)
|
||||
((+ 5 (quotient (bit-string-byte-count options) 4))
|
||||
:: integer bits 4) ;; TODO: enforce 4-byte alignment
|
||||
(0 :: integer bits 3)
|
||||
((flag-bit 'ns) :: integer bits 1)
|
||||
((flag-bit 'cwr) :: integer bits 1)
|
||||
((flag-bit 'ece) :: integer bits 1)
|
||||
((flag-bit 'urg) :: integer bits 1)
|
||||
((flag-bit 'ack) :: integer bits 1)
|
||||
((flag-bit 'psh) :: integer bits 1)
|
||||
((flag-bit 'rst) :: integer bits 1)
|
||||
((flag-bit 'syn) :: integer bits 1)
|
||||
((flag-bit 'fin) :: integer bits 1)
|
||||
(window-size :: integer bytes 2)
|
||||
(0 :: integer bytes 2) ;; checksum location
|
||||
(0 :: integer bytes 2) ;; TODO: urgent pointer
|
||||
(data :: binary)))
|
||||
(define pseudo-header (bit-string (src-ip :: binary bytes 4)
|
||||
(dst-ip :: binary bytes 4)
|
||||
0
|
||||
PROTOCOL-TCP
|
||||
((bit-string-byte-count payload) :: integer bytes 2)))
|
||||
(transition s (message (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
|
||||
(ip-checksum 16 payload #:pseudo-header pseudo-header)))))
|
||||
|
||||
(actor #:name 'kernel-tcp-driver
|
||||
(lambda (e s)
|
||||
(match e
|
||||
[(scn g)
|
||||
(analyze-gestalt g s)]
|
||||
[(message (ip-packet source-if src dst _ _ body))
|
||||
#:when (and source-if ;; source-if == #f iff packet originates locally
|
||||
(set-member? (codec-state-local-ips s) dst))
|
||||
(analyze-incoming-packet src dst body s)]
|
||||
[(message (? tcp-packet? p))
|
||||
#:when (not (tcp-packet-from-wire? p))
|
||||
(deliver-outbound-packet p s)]
|
||||
[_ #f]))
|
||||
(codec-state (set) (set))
|
||||
(scn/union (subscription (ip-packet ? ? ? PROTOCOL-TCP ? ?))
|
||||
(subscription (tcp-packet #f ? ? ? ? ? ? ? ? ? ?))
|
||||
(subscription (observe (tcp-packet #t ? ? ? ? ? ? ? ? ? ?)))
|
||||
observe-local-ip-addresses-gestalt)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Per-connection state vector process
|
||||
|
||||
(struct buffer (data ;; bit-string
|
||||
seqn ;; names leftmost byte in data
|
||||
window ;; counts bytes from leftmost byte in data
|
||||
finished?) ;; boolean: true after FIN
|
||||
#:transparent)
|
||||
|
||||
(struct conn-state (outbound ;; buffer
|
||||
inbound ;; buffer
|
||||
syn-acked? ;; boolean
|
||||
latest-peer-activity-time ;; from current-inexact-milliseconds
|
||||
;; ^ the most recent time we heard from our peer
|
||||
user-timeout-base-time ;; from current-inexact-milliseconds
|
||||
;; ^ when the index of the first outbound unacknowledged byte changed
|
||||
local-peer-seen? ;; boolean
|
||||
listener-listening?) ;; boolean
|
||||
#:transparent)
|
||||
|
||||
(define transmit-check-interval-msec 2000)
|
||||
(define inbound-buffer-limit 65535)
|
||||
(define maximum-segment-size 536) ;; bytes
|
||||
(define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout
|
||||
(define user-timeout-msec (* 5 60 1000)) ;; per RFC 793, this should be per-connection, but I
|
||||
;; cheat; RFC 793 says "the present global default is five minutes", which is
|
||||
;; reasonable to be getting on with
|
||||
|
||||
(define (spawn-state-vector src-ip src-port dst-ip dst-port)
|
||||
(define src (tcp-address (ip-address->hostname src-ip) src-port))
|
||||
(define dst (tcp-address (ip-address->hostname dst-ip) dst-port))
|
||||
(define (timer-name kind) (list 'tcp-timer kind src dst))
|
||||
|
||||
(define (next-expected-seqn s)
|
||||
(define b (conn-state-inbound s))
|
||||
(define v (buffer-seqn b))
|
||||
(and v (seq+ v (bit-string-byte-count (buffer-data b)))))
|
||||
|
||||
(define (buffer-push b data)
|
||||
(struct-copy buffer b [data (bit-string-append (buffer-data b) data)]))
|
||||
|
||||
;; ConnState -> ConnState
|
||||
(define (set-inbound-seqn seqn s)
|
||||
(struct-copy conn-state s
|
||||
[inbound (struct-copy buffer (conn-state-inbound s) [seqn seqn])]))
|
||||
|
||||
;; Bitstring ConnState -> Transition
|
||||
(define (incorporate-segment data s)
|
||||
;; (log-info "GOT INBOUND STUFF TO DELIVER ~v" data)
|
||||
(transition
|
||||
(if (buffer-finished? (conn-state-inbound s))
|
||||
s
|
||||
(struct-copy conn-state s [inbound (buffer-push (conn-state-inbound s) data)]))
|
||||
'()))
|
||||
|
||||
(define (seq+ a b) (bitwise-and #xffffffff (+ a b)))
|
||||
|
||||
;; Always positive
|
||||
(define (seq- larger smaller)
|
||||
(if (< larger smaller) ;; wraparound has occurred
|
||||
(+ (- larger smaller) #x100000000)
|
||||
(- larger smaller)))
|
||||
|
||||
(define (seq> a b)
|
||||
(< (seq- a b) #x80000000))
|
||||
|
||||
(define local-peer-detector (?! (observe (tcp-channel src dst ?))))
|
||||
(define listener-detector (?! (observe (advertise (tcp-channel ? (tcp-listener dst-port) ?)))))
|
||||
|
||||
;; ConnState -> Gestalt
|
||||
(define (compute-gestalt s)
|
||||
(define worldward-facing-gestalt
|
||||
(subscription (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?)))
|
||||
(define appward-facing-gestalt
|
||||
(assertion-set-union
|
||||
(subscription (projection->pattern local-peer-detector))
|
||||
(subscription (projection->pattern listener-detector))
|
||||
(subscription (tcp-channel dst src ?))
|
||||
(if (and (conn-state-syn-acked? s)
|
||||
(not (buffer-finished? (conn-state-inbound s))))
|
||||
(advertisement (tcp-channel src dst ?))
|
||||
trie-empty)))
|
||||
(assertion-set-union (subscription (timer-expired (timer-name ?) ?))
|
||||
worldward-facing-gestalt
|
||||
appward-facing-gestalt))
|
||||
|
||||
;; ConnState -> Transition
|
||||
(define (deliver-inbound-locally s)
|
||||
(define b (conn-state-inbound s))
|
||||
(if (bit-string-empty? (buffer-data b))
|
||||
(transition s '())
|
||||
(let ((chunk (bit-string->bytes (buffer-data b))))
|
||||
(transition (struct-copy conn-state s
|
||||
[inbound (struct-copy buffer b
|
||||
[data #""]
|
||||
[seqn (seq+ (buffer-seqn b) (bytes-length chunk))])])
|
||||
(message (tcp-channel src dst chunk))))))
|
||||
|
||||
;; (Setof Symbol) -> ConnState -> Transition
|
||||
(define ((check-fin flags) s)
|
||||
(define b (conn-state-inbound s))
|
||||
(unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
|
||||
(error 'check-fin "Nonempty inbound buffer"))
|
||||
(if (set-member? flags 'fin)
|
||||
(let ((new-s (struct-copy conn-state s
|
||||
[inbound (struct-copy buffer b
|
||||
[seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
|
||||
[finished? #t])])))
|
||||
(log-info "Closing inbound stream.")
|
||||
(transition new-s (scn (compute-gestalt new-s))))
|
||||
(transition s '())))
|
||||
|
||||
;; Boolean SeqNum -> ConnState -> Transition
|
||||
(define ((discard-acknowledged-outbound ack? ackn) s)
|
||||
(if (not ack?)
|
||||
(transition s '())
|
||||
(let* ((b (conn-state-outbound s))
|
||||
(base (buffer-seqn b))
|
||||
(limit (seq+ (buffer-seqn b) (bit-string-byte-count (buffer-data b))))
|
||||
(ackn (if (seq> ackn limit) limit ackn))
|
||||
(ackn (if (seq> base ackn) base ackn))
|
||||
(dist (seq- ackn base)))
|
||||
(define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
|
||||
(define new-s (struct-copy conn-state s
|
||||
[user-timeout-base-time (current-inexact-milliseconds)]
|
||||
[outbound (struct-copy buffer b [data remaining-data] [seqn ackn])]
|
||||
[syn-acked? (or (conn-state-syn-acked? s)
|
||||
(positive? dist))]))
|
||||
(transition new-s
|
||||
(when (and (not (conn-state-syn-acked? s)) (positive? dist))
|
||||
(scn (compute-gestalt new-s)))))))
|
||||
|
||||
;; Nat -> ConnState -> Transition
|
||||
(define ((update-outbound-window peer-window) s)
|
||||
(transition (struct-copy conn-state s
|
||||
[outbound (struct-copy buffer (conn-state-outbound s)
|
||||
[window peer-window])])
|
||||
'()))
|
||||
|
||||
;; ConnState -> Boolean
|
||||
(define (all-output-acknowledged? s)
|
||||
(bit-string-empty? (buffer-data (conn-state-outbound s))))
|
||||
|
||||
;; (Option SeqNum) -> ConnState -> Transition
|
||||
(define ((send-outbound old-ackn) s)
|
||||
(define b (conn-state-outbound s))
|
||||
(define pending-byte-count (max 0 (- (bit-string-byte-count (buffer-data b))
|
||||
(if (buffer-finished? b) 1 0))))
|
||||
|
||||
(define segment-size (min maximum-segment-size
|
||||
(if (conn-state-syn-acked? s) (buffer-window b) 1)
|
||||
;; ^ can only send SYN until SYN is acked
|
||||
pending-byte-count))
|
||||
(define segment-offset (if (conn-state-syn-acked? s) 0 1))
|
||||
(define chunk0 (bit-string-take (buffer-data b) (* segment-size 8))) ;; bit offset!
|
||||
(define chunk (bit-string-drop chunk0 (* segment-offset 8))) ;; bit offset!
|
||||
(define ackn (next-expected-seqn s))
|
||||
(define flags (set))
|
||||
(when ackn
|
||||
(set! flags (set-add flags 'ack)))
|
||||
(when (not (conn-state-syn-acked? s))
|
||||
(set! flags (set-add flags 'syn)))
|
||||
(when (and (buffer-finished? b)
|
||||
(conn-state-syn-acked? s)
|
||||
(= segment-size pending-byte-count)
|
||||
(not (all-output-acknowledged? s))) ;; TODO: reexamine. This looks fishy
|
||||
(set! flags (set-add flags 'fin)))
|
||||
(define window (min 65535 ;; limit of field width
|
||||
(max 0 ;; can't be negative
|
||||
(- (buffer-window (conn-state-inbound s))
|
||||
(bit-string-byte-count
|
||||
(buffer-data (conn-state-inbound s)))))))
|
||||
(transition s
|
||||
(unless (and (equal? ackn old-ackn)
|
||||
(conn-state-syn-acked? s)
|
||||
(not (set-member? flags 'fin))
|
||||
(zero? (bit-string-byte-count chunk)))
|
||||
(local-require racket/pretty)
|
||||
(pretty-write `(send-outbound (old-ackn ,old-ackn)
|
||||
(s ,s)
|
||||
(flags ,flags)))
|
||||
(flush-output)
|
||||
(message (tcp-packet #f dst-ip dst-port src-ip src-port
|
||||
(buffer-seqn b)
|
||||
(or ackn 0)
|
||||
flags
|
||||
window
|
||||
#""
|
||||
chunk)))))
|
||||
|
||||
;; ConnState -> Transition
|
||||
(define (bump-peer-activity-time s)
|
||||
(transition (struct-copy conn-state s
|
||||
[latest-peer-activity-time (current-inexact-milliseconds)])
|
||||
'()))
|
||||
|
||||
;; ConnState Number -> Boolean
|
||||
(define (heard-from-peer-within-msec? s msec)
|
||||
(<= (- (current-inexact-milliseconds) (conn-state-latest-peer-activity-time s)) msec))
|
||||
|
||||
;; ConnState -> Boolean
|
||||
(define (user-timeout-expired? s)
|
||||
(and (not (all-output-acknowledged? s))
|
||||
(> (- (current-inexact-milliseconds) (conn-state-user-timeout-base-time s))
|
||||
user-timeout-msec)))
|
||||
|
||||
;; ConnState -> Transition
|
||||
(define (quit-when-done s)
|
||||
(cond
|
||||
[(and (buffer-finished? (conn-state-outbound s))
|
||||
(buffer-finished? (conn-state-inbound s))
|
||||
(all-output-acknowledged? s)
|
||||
(not (heard-from-peer-within-msec? s (* 2 1000 maximum-segment-lifetime-sec))))
|
||||
;; Everything is cleanly shut down, and we just need to wait a while for unexpected
|
||||
;; packets before we release the state vector.
|
||||
(quit)]
|
||||
[(user-timeout-expired? s)
|
||||
;; We've been plaintively retransmitting for user-timeout-msec without hearing anything
|
||||
;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but
|
||||
;; it will do for now? TODO
|
||||
(log-info "TCP_USER_TIMEOUT fired.")
|
||||
(quit)]
|
||||
[else #f]))
|
||||
|
||||
;; Action
|
||||
(define send-set-transmit-check-timer
|
||||
(message (set-timer (timer-name 'transmit-check)
|
||||
transmit-check-interval-msec
|
||||
'relative)))
|
||||
|
||||
;; SeqNum SeqNum ConnState -> Transition
|
||||
(define (reset seqn ackn s)
|
||||
(log-warning "Sending RST from ~a:~a to ~a:~a"
|
||||
(ip-address->hostname dst-ip)
|
||||
dst-port
|
||||
(ip-address->hostname src-ip)
|
||||
src-port)
|
||||
(quit (message (tcp-packet #f dst-ip dst-port src-ip src-port
|
||||
seqn
|
||||
ackn
|
||||
(set 'ack 'rst)
|
||||
0
|
||||
#""
|
||||
#""))))
|
||||
|
||||
;; ConnState -> Transition
|
||||
(define (close-outbound-stream s)
|
||||
(define b (conn-state-outbound s))
|
||||
(transition
|
||||
(if (buffer-finished? b)
|
||||
s
|
||||
(struct-copy conn-state s
|
||||
[outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte
|
||||
[finished? #t])]))
|
||||
'()))
|
||||
|
||||
(define (state-vector-behavior e s)
|
||||
(define old-ackn (buffer-seqn (conn-state-inbound s)))
|
||||
(match e
|
||||
[(scn g)
|
||||
(log-info "State vector routing-update:\n~a" (trie->pretty-string g))
|
||||
(define local-peer-present? (trie-non-empty? (trie-project g local-peer-detector)))
|
||||
(define listening? (trie-non-empty? (trie-project g listener-detector)))
|
||||
(define new-s (struct-copy conn-state s [listener-listening? listening?]))
|
||||
(cond
|
||||
[(and local-peer-present? (not (conn-state-local-peer-seen? s)))
|
||||
(transition (struct-copy conn-state new-s [local-peer-seen? #t]) '())]
|
||||
[(and (not local-peer-present?) (conn-state-local-peer-seen? s))
|
||||
(log-info "Closing outbound stream.")
|
||||
(sequence-transitions (close-outbound-stream new-s)
|
||||
(send-outbound old-ackn)
|
||||
quit-when-done)]
|
||||
[else (transition new-s '())])]
|
||||
[(message (tcp-packet #t _ _ _ _ seqn ackn flags window options data))
|
||||
(define expected (next-expected-seqn s))
|
||||
(define is-syn? (set-member? flags 'syn))
|
||||
(define is-fin? (set-member? flags 'fin))
|
||||
(cond
|
||||
[(set-member? flags 'rst) (quit)]
|
||||
[(and (not expected) ;; no syn yet
|
||||
(or (not is-syn?) ;; and this isn't it
|
||||
(and (not (conn-state-listener-listening? s)) ;; or it is, but no listener...
|
||||
(not (conn-state-local-peer-seen? s))))) ;; ...and no outbound client
|
||||
(reset ackn ;; this is *our* seqn
|
||||
(seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0)))
|
||||
;; ^^ this is what we should acknowledge...
|
||||
s)]
|
||||
[else
|
||||
(sequence-transitions (cond
|
||||
[(not expected) ;; haven't seen syn yet, but we know this is it
|
||||
(incorporate-segment data (set-inbound-seqn (seq+ seqn 1) s))]
|
||||
[(= expected seqn)
|
||||
(incorporate-segment data s)]
|
||||
[else
|
||||
(transition s '())])
|
||||
deliver-inbound-locally
|
||||
(check-fin flags)
|
||||
(discard-acknowledged-outbound (set-member? flags 'ack) ackn)
|
||||
(update-outbound-window window)
|
||||
(send-outbound old-ackn)
|
||||
bump-peer-activity-time
|
||||
quit-when-done)])]
|
||||
[(message (tcp-channel _ _ bs))
|
||||
;; (log-info "GOT MORE STUFF TO DELIVER ~v" bs)
|
||||
(sequence-transitions (transition (struct-copy conn-state s
|
||||
[user-timeout-base-time
|
||||
;; Only move user-timeout-base-time if there wasn't
|
||||
;; already some outstanding output.
|
||||
(if (all-output-acknowledged? s)
|
||||
(current-inexact-milliseconds)
|
||||
(conn-state-user-timeout-base-time s))]
|
||||
[outbound (buffer-push (conn-state-outbound s) bs)])
|
||||
'())
|
||||
(send-outbound old-ackn)
|
||||
quit-when-done)]
|
||||
[(message (timer-expired (== (timer-name 'transmit-check)) _))
|
||||
;; TODO: I am abusing this timer for multiple tasks. Notably, this is a (crude) means of
|
||||
;; retransmitting outbound data as well as a means of checking for an expired
|
||||
;; TCP_USER_TIMEOUT. A better design would have separate timers and a more fine-grained
|
||||
;; approach.
|
||||
(sequence-transitions (transition s send-set-transmit-check-timer)
|
||||
(send-outbound old-ackn)
|
||||
quit-when-done)]
|
||||
[_ #f]))
|
||||
|
||||
;; (local-require racket/trace)
|
||||
;; (trace state-vector-behavior)
|
||||
|
||||
(define initial-outbound-seqn
|
||||
;; Yuck
|
||||
(inexact->exact (truncate (* #x100000000 (random)))))
|
||||
|
||||
;; TODO accept input from user process
|
||||
(list
|
||||
send-set-transmit-check-timer
|
||||
(let ((state0 (conn-state (buffer #"!" initial-outbound-seqn 0 #f) ;; dummy data at SYN position
|
||||
(buffer #"" #f inbound-buffer-limit #f)
|
||||
#f
|
||||
(current-inexact-milliseconds)
|
||||
(current-inexact-milliseconds)
|
||||
#f
|
||||
#f)))
|
||||
(actor #:name
|
||||
(string->symbol (format "tcp-state-vector:~a:~a:~a:~a"
|
||||
(ip-address->hostname src-ip)
|
||||
src-port
|
||||
(ip-address->hostname dst-ip)
|
||||
dst-port))
|
||||
state-vector-behavior
|
||||
state0
|
||||
(scn (compute-gestalt state0))))))
|
|
@ -0,0 +1,176 @@
|
|||
#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 syndicate/monolithic)
|
||||
(require syndicate/demand-matcher)
|
||||
(require syndicate/protocol/advertise)
|
||||
(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)))
|
||||
|
||||
;; 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)
|
||||
|
||||
(define any-remote (udp-remote-address ? ?))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; User-accessible driver startup
|
||||
|
||||
(define (spawn-udp-driver)
|
||||
(list
|
||||
(spawn-demand-matcher (observe (udp-packet ? (?! (udp-listener ?)) ?))
|
||||
(advertise (udp-packet ? (?! (udp-listener ?)) ?))
|
||||
(lambda (handle) (spawn-udp-relay (udp-listener-port handle) handle)))
|
||||
(spawn-demand-matcher (observe (udp-packet ? (?! (udp-handle ?)) ?))
|
||||
(advertise (udp-packet ? (?! (udp-handle ?)) ?))
|
||||
(lambda (handle)
|
||||
(message (port-allocation-request
|
||||
'udp
|
||||
(lambda (port local-ips) (spawn-udp-relay port handle))))))
|
||||
(spawn-udp-port-allocator)
|
||||
(spawn-kernel-udp-driver)))
|
||||
|
||||
(define (spawn-udp-port-allocator)
|
||||
(define udp-projector (udp-port-allocation (?!) ?))
|
||||
(spawn-port-allocator 'udp
|
||||
(subscription (projection->pattern udp-projector))
|
||||
(lambda (g local-ips)
|
||||
(project-assertions g udp-projector))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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-detector (?! (observe (udp-packet any-remote local-user-addr ?))))
|
||||
|
||||
(define (compute-gestalt local-ips)
|
||||
(for/fold [(g (assertion-set-union
|
||||
(subscription (projection->pattern local-peer-detector))
|
||||
(advertisement (udp-packet any-remote local-user-addr ?))
|
||||
observe-local-ip-addresses-gestalt
|
||||
(subscription (udp-packet local-user-addr any-remote ?))
|
||||
(assertion (udp-port-allocation local-port local-user-addr))))]
|
||||
[(ip (in-set local-ips))]
|
||||
(assertion-set-union g
|
||||
(subscription (udp-datagram ? ? ip local-port ?))
|
||||
(advertisement (udp-datagram ip local-port ? ? ?)))))
|
||||
|
||||
(actor (lambda (e local-ips)
|
||||
(match e
|
||||
[(scn g)
|
||||
(define new-local-ips (gestalt->local-ip-addresses g))
|
||||
(if (trie-empty? (trie-project g local-peer-detector))
|
||||
(quit)
|
||||
(transition new-local-ips (scn (compute-gestalt new-local-ips))))]
|
||||
[(message (udp-packet (== local-user-addr) remote-addr bs))
|
||||
;; Choose arbitrary local IP address for outbound packet!
|
||||
;; TODO: what can be done? Must I examine the routing table?
|
||||
(match-define (udp-remote-address remote-host remote-port) remote-addr)
|
||||
(define remote-ip (ip-string->ip-address remote-host))
|
||||
(transition local-ips (message (udp-datagram (set-first local-ips)
|
||||
local-port
|
||||
remote-ip
|
||||
remote-port
|
||||
bs)))]
|
||||
[(message (udp-datagram si sp _ _ bs))
|
||||
(transition local-ips
|
||||
(message (udp-packet (udp-remote-address (ip-address->hostname si) sp)
|
||||
local-user-addr
|
||||
bs)))]
|
||||
[_ #f]))
|
||||
(set)
|
||||
(scn (compute-gestalt (set)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Codec & kernel-level driver
|
||||
|
||||
(define PROTOCOL-UDP 17)
|
||||
|
||||
(define (spawn-kernel-udp-driver)
|
||||
(actor (lambda (e local-ips)
|
||||
(match e
|
||||
[(scn 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))
|
||||
(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 (message (udp-datagram src-ip
|
||||
src-port
|
||||
dst-ip
|
||||
dst-port
|
||||
(bit-string->bytes payload)))))
|
||||
(else #f)))
|
||||
(else #f))]
|
||||
[(message (udp-datagram src-ip src-port dst-ip dst-port bs))
|
||||
#:when (set-member? local-ips src-ip)
|
||||
(let* ((payload (bit-string (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
((+ 8 (bit-string-byte-count bs))
|
||||
:: integer bytes 2)
|
||||
(0 :: integer bytes 2) ;; checksum location
|
||||
(bs :: binary)))
|
||||
(pseudo-header (bit-string (src-ip :: binary bytes 4)
|
||||
(dst-ip :: binary bytes 4)
|
||||
0
|
||||
PROTOCOL-UDP
|
||||
((bit-string-byte-count payload)
|
||||
:: integer bytes 2)))
|
||||
(checksummed-payload (ip-checksum #:pseudo-header pseudo-header
|
||||
6 payload)))
|
||||
(transition local-ips (message (ip-packet #f
|
||||
src-ip
|
||||
dst-ip
|
||||
PROTOCOL-UDP
|
||||
#""
|
||||
checksummed-payload))))]
|
||||
[_ #f]))
|
||||
(set)
|
||||
(scn/union (advertisement (ip-packet #f ? ? PROTOCOL-UDP ? ?))
|
||||
(subscription (ip-packet ? ? ? PROTOCOL-UDP ? ?))
|
||||
(subscription (udp-datagram ? ? ? ? ?))
|
||||
observe-local-ip-addresses-gestalt)))
|
|
@ -0,0 +1 @@
|
|||
compiled/
|
|
@ -0,0 +1,11 @@
|
|||
# Operational Transformation
|
||||
|
||||
The program `syndicate-server.rkt` is a port of
|
||||
[`server.rkt`](https://github.com/tonyg/racket-operational-transformation/blob/master/operational-transformation-demo/server.rkt)
|
||||
to Syndicate.
|
||||
|
||||
It accepts the same command-line arguments, and works with unmodified
|
||||
[clients](https://github.com/tonyg/racket-operational-transformation/blob/master/operational-transformation-demo/client.rkt);
|
||||
see the
|
||||
[README](https://github.com/tonyg/racket-operational-transformation/blob/master/README.md)
|
||||
for more information.
|
|
@ -0,0 +1,106 @@
|
|||
#lang syndicate
|
||||
|
||||
(require racket/file)
|
||||
(require racket/serialize)
|
||||
(require racket/set)
|
||||
(require operational-transformation)
|
||||
(require operational-transformation/text/simple-document)
|
||||
|
||||
(require syndicate/protocol/advertise)
|
||||
(require/activate syndicate/drivers/tcp)
|
||||
(require/activate syndicate/drivers/line-reader)
|
||||
|
||||
(struct snapshot-for (filename snap) #:prefab)
|
||||
(struct proposed-op (filename p) #:prefab)
|
||||
(struct accepted-op (filename p) #:prefab)
|
||||
(struct client-seen-up-to (filename revision) #:prefab)
|
||||
|
||||
(define cmdline-port (make-parameter 5889))
|
||||
(define cmdline-filenames (make-parameter '()))
|
||||
|
||||
(spawn* (for [(filename (cmdline-filenames))]
|
||||
(run-one-server filename)))
|
||||
|
||||
(define (run-one-server filename)
|
||||
(spawn (field [state (make-server (simple-document
|
||||
(if (file-exists? filename)
|
||||
(begin (log-info "loading ~v" filename)
|
||||
(file->string filename))
|
||||
(begin (log-info "will create ~v" filename)
|
||||
""))))])
|
||||
(assert (snapshot-for filename (extract-snapshot (state))))
|
||||
|
||||
(define/query-set client-seen-revs (client-seen-up-to filename $rev) rev)
|
||||
(field [oldest-needed-rev #f])
|
||||
(begin/dataflow
|
||||
(define min-rev
|
||||
(or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
|
||||
(min (or min-rev rev) rev))
|
||||
(server-state-revision (state))))
|
||||
(when (not (equal? (oldest-needed-rev) min-rev))
|
||||
(oldest-needed-rev min-rev)
|
||||
(state (forget-operation-history (state) min-rev))))
|
||||
|
||||
(begin/dataflow
|
||||
(display-to-file (simple-document-text (server-state-document (state)))
|
||||
filename
|
||||
#:exists 'replace))
|
||||
|
||||
(on (message (proposed-op filename $p))
|
||||
(state (incorporate-operation-from-client (state) p))
|
||||
(define sp (extract-operation (state)))
|
||||
(when sp (send! (accepted-op filename sp))))))
|
||||
|
||||
(spawn (define s (tcp-listener (cmdline-port)))
|
||||
(on-start (log-info "listening on port ~v" (cmdline-port)))
|
||||
(assert (advertise (observe (tcp-channel _ s _))))
|
||||
(during/spawn (advertise (tcp-channel $c s _))
|
||||
(assert (advertise (tcp-channel s c _)))
|
||||
(on-start (log-info "~a: connected" c))
|
||||
(on-stop (log-info "~a: disconnected" c))
|
||||
(connection-react c s)))
|
||||
|
||||
(define (connection-react c s)
|
||||
(define (output v)
|
||||
;; (log-info "~a: sending them ~v" c v)
|
||||
(define p (open-output-bytes))
|
||||
(write (serialize v) p)
|
||||
(newline p)
|
||||
(send! (tcp-channel s c (get-output-bytes p))))
|
||||
|
||||
(field [seen-up-to 0])
|
||||
(field [selected-filename #f])
|
||||
|
||||
(assert #:when (selected-filename) (client-seen-up-to (selected-filename) (seen-up-to)))
|
||||
|
||||
(define/query-set available-filenames (observe (proposed-op $f _)) f)
|
||||
(begin/dataflow
|
||||
(output (set->list (available-filenames))))
|
||||
|
||||
(begin/dataflow
|
||||
(when (selected-filename)
|
||||
(log-info "~a: attached to file ~a" c (selected-filename))
|
||||
(let-event [(asserted (snapshot-for (selected-filename) $snapshot))]
|
||||
(output snapshot)
|
||||
(seen-up-to (server-snapshot-revision snapshot)))))
|
||||
(on #:when (selected-filename)
|
||||
(message (accepted-op (selected-filename) $p))
|
||||
(output p))
|
||||
|
||||
(on (message (tcp-channel-line c s $line))
|
||||
(match (deserialize (read (open-input-bytes line)))
|
||||
[(? string? new-filename)
|
||||
(when (selected-filename) (log-info "~a: detached from file ~a" c (selected-filename)))
|
||||
(seen-up-to 0)
|
||||
(selected-filename new-filename)]
|
||||
[(? number? n) (seen-up-to n)]
|
||||
[(? pending-operation? p) (send! (proposed-op (selected-filename) p))])))
|
||||
|
||||
(module+ main
|
||||
(require racket/cmdline)
|
||||
(command-line
|
||||
#:once-each
|
||||
[("-p" "--port") server-port ((format "Server port (default ~v)" (cmdline-port)))
|
||||
(cmdline-port (string->number server-port))]
|
||||
#:args filenames
|
||||
(cmdline-filenames filenames)))
|
|
@ -0,0 +1,88 @@
|
|||
#lang syndicate
|
||||
|
||||
(require racket/file)
|
||||
(require racket/serialize)
|
||||
(require operational-transformation)
|
||||
(require operational-transformation/text/simple-document)
|
||||
|
||||
(require syndicate/protocol/advertise)
|
||||
(require/activate syndicate/drivers/tcp)
|
||||
(require/activate syndicate/drivers/line-reader)
|
||||
|
||||
(struct proposed-op (p) #:prefab)
|
||||
(struct accepted-op (p) #:prefab)
|
||||
(struct client-seen-up-to (revision) #:prefab)
|
||||
|
||||
(define cmdline-port (make-parameter 5888))
|
||||
(define cmdline-filename (make-parameter "info.rkt"))
|
||||
|
||||
(spawn (field [state (make-server (simple-document
|
||||
(if (file-exists? (cmdline-filename))
|
||||
(begin (log-info "loading ~v" (cmdline-filename))
|
||||
(file->string (cmdline-filename)))
|
||||
(begin (log-info "will create ~v" (cmdline-filename))
|
||||
""))))])
|
||||
(assert (extract-snapshot (state)))
|
||||
|
||||
(define/query-set client-seen-revs (client-seen-up-to $rev) rev)
|
||||
(field [oldest-needed-rev #f])
|
||||
(begin/dataflow
|
||||
(define min-rev
|
||||
(or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
|
||||
(min (or min-rev rev) rev))
|
||||
(server-state-revision (state))))
|
||||
(when (not (equal? (oldest-needed-rev) min-rev))
|
||||
(oldest-needed-rev min-rev)
|
||||
(state (forget-operation-history (state) min-rev))))
|
||||
|
||||
(begin/dataflow
|
||||
(display-to-file (simple-document-text (server-state-document (state)))
|
||||
(cmdline-filename)
|
||||
#:exists 'replace))
|
||||
|
||||
(on (message (proposed-op $p))
|
||||
(state (incorporate-operation-from-client (state) p))
|
||||
(define sp (extract-operation (state)))
|
||||
(when sp (send! (accepted-op sp)))))
|
||||
|
||||
(spawn (define s (tcp-listener (cmdline-port)))
|
||||
(on-start (log-info "listening on port ~v" (cmdline-port)))
|
||||
(assert (advertise (observe (tcp-channel _ s _))))
|
||||
(during/spawn (advertise (tcp-channel $c s _))
|
||||
(assert (advertise (tcp-channel s c _)))
|
||||
(on-start (log-info "~a: connected" c))
|
||||
(on-stop (log-info "~a: disconnected" c))
|
||||
(connection-react c s (cmdline-filename))))
|
||||
|
||||
(define (connection-react c s filename)
|
||||
(define (output v)
|
||||
;; (log-info "~a: sending them ~v" c v)
|
||||
(define p (open-output-bytes))
|
||||
(write (serialize v) p)
|
||||
(newline p)
|
||||
(send! (tcp-channel s c (get-output-bytes p))))
|
||||
|
||||
(field [seen-up-to 0])
|
||||
(assert (client-seen-up-to (seen-up-to)))
|
||||
|
||||
(on-start
|
||||
(output filename)
|
||||
(let-event [(asserted ($ snapshot (server-snapshot _ _)))]
|
||||
(output snapshot)
|
||||
(seen-up-to (server-snapshot-revision snapshot))
|
||||
(react (on (message (accepted-op $p))
|
||||
(output p)))))
|
||||
|
||||
(on (message (tcp-channel-line c s $line))
|
||||
(match (deserialize (read (open-input-bytes line)))
|
||||
[(? number? n) (seen-up-to n)]
|
||||
[(? pending-operation? p) (send! (proposed-op p))])))
|
||||
|
||||
(module+ main
|
||||
(require racket/cmdline)
|
||||
(command-line
|
||||
#:once-each
|
||||
[("-p" "--port") server-port ((format "Server port (default ~v)" (cmdline-port)))
|
||||
(cmdline-port (string->number server-port))]
|
||||
#:args (filename)
|
||||
(cmdline-filename filename)))
|
|
@ -0,0 +1 @@
|
|||
compiled/
|
Binary file not shown.
After Width: | Height: | Size: 250 KiB |
|
@ -0,0 +1,819 @@
|
|||
#lang syndicate
|
||||
|
||||
(require 2htdp/image)
|
||||
(require 2htdp/planetcute)
|
||||
|
||||
(require racket/set)
|
||||
(require plot/utils) ;; for vector utilities
|
||||
|
||||
(require (only-in racket/string string-prefix?))
|
||||
(require (only-in racket/gui/base play-sound))
|
||||
|
||||
(require/activate syndicate/drivers/timer)
|
||||
|
||||
(require syndicate-gl/2d)
|
||||
(module+ main (current-ground-dataspace (2d-dataspace #:width 600 #:height 400)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Layers:
|
||||
;;
|
||||
;; - External I/O
|
||||
;; as arranged by syndicate-gl/2d
|
||||
;; including keyboard events, interface to rendering, and frame timing
|
||||
;;
|
||||
;; - Ground
|
||||
;; corresponds to computer itself
|
||||
;; device drivers
|
||||
;; applications (e.g. in this instance, the game)
|
||||
;;
|
||||
;; - Game
|
||||
;; running application
|
||||
;; per-game state, such as score and count-of-deaths
|
||||
;; process which spawns levels
|
||||
;; regular frame ticker
|
||||
;;
|
||||
;; - Level
|
||||
;; model of the game world
|
||||
;; actors represent entities in the world, mostly
|
||||
;; misc actors do physicsish things
|
||||
;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ## Common Data Definitions
|
||||
;;
|
||||
;; A Vec is a (vector Number Number)
|
||||
;; A Point is a (vector Number Number)
|
||||
;; (See vector functions in plot/utils)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ## Ground Layer Protocols
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Scene Management
|
||||
;; - assertion: ScrollOffset
|
||||
;; - assertion: OnScreenDisplay
|
||||
;; - role: SceneManager
|
||||
;; Displays the scene backdrop and adjusts display coordinates via ScrollOffset.
|
||||
;;
|
||||
;; A ScrollOffset is a (scroll-offset Vec), indicating the vector to *subtract*
|
||||
;; from world coordinates to get device coordinates.
|
||||
(struct scroll-offset (vec) #:transparent)
|
||||
;;
|
||||
;; An OnScreenDisplay is an (on-screen-display Number Number (Seal Image)),
|
||||
;; representing an item to display in a fixed window-relative position
|
||||
;; above the scrolled part of the scene. If the coordinates are
|
||||
;; positive, they measure right/down from the left/top of the image;
|
||||
;; if negative, they measure left/up from the right/bottom.
|
||||
(struct on-screen-display (x y sealed-image) #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ## Game Layer Protocols
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Scoring
|
||||
;; - message: AddToScore
|
||||
;; - assertion: CurrentScore
|
||||
;; - role: ScoreKeeper
|
||||
;; Maintains the score as private state.
|
||||
;; Publishes the score using a CurrentScore.
|
||||
;; Responds to AddToScore by updating the score.
|
||||
;;
|
||||
;; An AddToScore is an (add-to-score Number), a message
|
||||
;; which signals a need to add the given number to the player's
|
||||
;; current score.
|
||||
(struct add-to-score (delta) #:transparent)
|
||||
;;
|
||||
;; A CurrentScore is a (current-score Number), an assertion
|
||||
;; indicating the player's current score.
|
||||
(struct current-score (value) #:transparent)
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Level Spawning
|
||||
;; - assertion: LevelRunning
|
||||
;; - message: LevelCompleted
|
||||
;; - role: LevelSpawner
|
||||
;; Maintains the current level number as private state.
|
||||
;; Spawns a new Level when required.
|
||||
;; Monitors LevelRunning - when it drops, the level is over.
|
||||
;; Receives LevelCompleted messages. If LevelRunning drops without
|
||||
;; a LevelCompleted having arrived, the level ended in failure and
|
||||
;; should be restarted. If LevelComplete arrived before LevelRunning
|
||||
;; dropped, the level was completed successfully, and the next level
|
||||
;; should be presented.
|
||||
;; - role: Level
|
||||
;; Running level instance. Maintains LevelRunning while it's still
|
||||
;; going. Sends LevelCompleted if the player successfully completed
|
||||
;; the level.
|
||||
;;
|
||||
;; A LevelRunning is a (level-running), an assertion indicating that the
|
||||
;; current level is still in progress.
|
||||
(struct level-running () #:transparent)
|
||||
;;
|
||||
;; A LevelCompleted is a (level-completed), a message indicating that
|
||||
;; the current level was *successfully* completed before it terminated.
|
||||
(struct level-completed () #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ## Level Layer Protocols
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Movement and Physics
|
||||
;; - message: JumpRequest
|
||||
;; - assertion: Impulse
|
||||
;; - assertion: Position
|
||||
;; - assertion: GamePieceConfiguration
|
||||
;; - assertion: Touching
|
||||
;; - role: PhysicsEngine
|
||||
;; Maintains positions, velocities and accelerations of all GamePieces.
|
||||
;; Uses GamePieceConfiguration for global properties of pieces.
|
||||
;; Publishes Position to match.
|
||||
;; Listens to FrameDescription, using it to advance the simulation.
|
||||
;; Considers only mobile GamePieces for movement.
|
||||
;; Takes Impulses as the baseline for moving GamePieces around.
|
||||
;; For massive mobile GamePieces, applies gravitational acceleration.
|
||||
;; Computes collisions between GamePieces.
|
||||
;; Uses Attributes of GamePieces to decide what to do in response to collisions.
|
||||
;; For 'touchable GamePieces, a Touching row is asserted.
|
||||
;; Responds to JumpRequest by checking whether the named piece is in a
|
||||
;; jumpable location, and sets its upward velocity negative if so.
|
||||
;; - role: GamePiece
|
||||
;; Maintains private state. Asserts Impulse to move around,
|
||||
;; and GamePieceConfiguration to get things started. May issue
|
||||
;; JumpRequests at any time. Represents both the player,
|
||||
;; enemies, the goal(s), and platforms and blocks in the
|
||||
;; environment. Asserts a Sprite two layers out to render
|
||||
;; itself.
|
||||
;;
|
||||
;; An ID is a Symbol; the special symbol 'player indicates the player's avatar.
|
||||
;; Gensyms from (gensym 'enemy) name enemies, etc.
|
||||
;;
|
||||
;; A JumpRequest is a (jump-request ID), a message indicating a *request* to jump,
|
||||
;; not necessarily honoured by the physics engine.
|
||||
(struct jump-request (id) #:transparent)
|
||||
;;
|
||||
;; An Impulse is an (impulse ID Vec), an assertion indicating a contribution to
|
||||
;; the net *requested* velocity of the given gamepiece.
|
||||
(struct impulse (id vec) #:transparent)
|
||||
;;
|
||||
;; A Position is a (position ID Point Vec), an assertion describing
|
||||
;; the current actual top-left corner and (physics-related, not
|
||||
;; necessarily graphics-related) size of the named gamepiece.
|
||||
(struct position (id top-left size) #:transparent)
|
||||
;;
|
||||
;; An Attribute is either
|
||||
;; - 'player - the named piece is a player avatar
|
||||
;; - 'touchable - the named piece reacts to the player's touch
|
||||
;; - 'solid - the named piece can be stood on / jumped from
|
||||
;; - 'mobile - the named piece is not fixed in place
|
||||
;; - 'massive - the named piece is subject to effects of gravity
|
||||
;; (it is an error to be 'massive but not 'mobile)
|
||||
;;
|
||||
;; A GamePieceConfiguration is a
|
||||
;; - (game-piece-configuration ID Point Vec (Set Attribute))
|
||||
;; an assertion specifying not only the *existence* of a named
|
||||
;; gamepiece, but also its initial position and size and a collection
|
||||
;; of its Attributes.
|
||||
(struct game-piece-configuration (id initial-position size attributes) #:transparent)
|
||||
;;
|
||||
;; A Touching is a
|
||||
;; - (touching ID ID Side)
|
||||
;; an assertion indicating that the first ID is touching the second on
|
||||
;; the named side of the second ID.
|
||||
(struct touching (a b side) #:transparent)
|
||||
;;
|
||||
;; A Side is either 'top, 'left, 'right, 'bottom or the special value
|
||||
;; 'mid, indicating an unknown or uncomputable side.
|
||||
|
||||
(define (game-piece-has-attribute? g attr)
|
||||
(set-member? (game-piece-configuration-attributes g) attr))
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### Player State
|
||||
;; - message: Damage
|
||||
;; - assertion: Health
|
||||
;; - role: Player
|
||||
;; Maintains hitpoints, which it reflects using Health.
|
||||
;; Responds to Damage.
|
||||
;; When hitpoints drop low enough, removes the player from the board.
|
||||
;;
|
||||
;; A Damage is a (damage ID Number), a message indicating an event that should
|
||||
;; consume the given number of health points of the named gamepiece.
|
||||
(struct damage (id hit-points) #:transparent)
|
||||
;;
|
||||
;; A Health is a (health ID Number), an assertion describing the current hitpoints
|
||||
;; of the named gamepiece.
|
||||
(struct health (id hit-points) #:transparent)
|
||||
|
||||
;;-------------------------------------------------------------------------
|
||||
;; ### World State
|
||||
;; - assertion: LevelSize
|
||||
;; - role: DisplayControl
|
||||
;; Maintains a LevelSize assertion.
|
||||
;; Observes the Position of the player, and computes and maintains a
|
||||
;; ScrollOffset two layers out, to match.
|
||||
;; Also kills the player if they wander below the bottom of the level.
|
||||
;;
|
||||
;; A LevelSize is a (level-size Vec), an assertion describing the right-hand and
|
||||
;; bottom edges of the level canvas (in World coordinates).
|
||||
(struct level-size (vec) #:transparent)
|
||||
|
||||
;; -----------
|
||||
;; Interaction Diagrams (to be refactored into the description later)
|
||||
;;
|
||||
;; ================================================================================
|
||||
;;
|
||||
;; title Jump Sequence
|
||||
;;
|
||||
;; Player -> Physics: (jump 'player)
|
||||
;; note right of Physics: Considers the request.
|
||||
;; note right of Physics: Denied -- Player is not on a surface.
|
||||
;;
|
||||
;; Player -> Physics: (jump 'player)
|
||||
;; note right of Physics: Considers the request.
|
||||
;; note right of Physics: Accepted.
|
||||
;; note right of Physics: Updates velocity, position
|
||||
;; Physics -> Subscribers: (vel 'player ...)
|
||||
;; Physics -> Subscribers: (pos 'player ...)
|
||||
;;
|
||||
;;
|
||||
;; ================================================================================
|
||||
;;
|
||||
;; title Display Control Updates
|
||||
;;
|
||||
;; Physics -> DisplayCtl: (pos 'player ...)
|
||||
;; note right of DisplayCtl: Compares player pos to level size
|
||||
;; DisplayCtl -> Subscribers: (inbound (inbound (scroll-offset ...)))
|
||||
;;
|
||||
;; ================================================================================
|
||||
;;
|
||||
;; title Movement Sequence
|
||||
;;
|
||||
;; Moveable -> Physics: (mobile ID Boolean)
|
||||
;; Moveable -> Physics: (attr ID ...)
|
||||
;; Moveable -> Physics: (impulse ID vec)
|
||||
;; note right of Physics: Processes simulation normally
|
||||
;; Physics -> Subscribers: (pos ID ...)
|
||||
;; Physics -> Subscribers: (vel ID ...)
|
||||
;;
|
||||
;; ================================================================================
|
||||
;;
|
||||
;; title Keyboard Interpretation
|
||||
;;
|
||||
;; Keyboard -> Player: (press right-arrow)
|
||||
;; Player -->> Physics: assert (impulse ID (vec DX 0))
|
||||
;;
|
||||
;; note right of Physics: Processes simulation normally
|
||||
;;
|
||||
;; Keyboard -> Player: (press left-arrow)
|
||||
;; Player -->> Physics: assert (impulse ID (vec 0 0))
|
||||
;;
|
||||
;; Keyboard -> Player: (release right-arrow)
|
||||
;; Player -->> Physics: assert (impulse ID (vec -DX 0))
|
||||
;;
|
||||
;; Keyboard -> Player: (press space)
|
||||
;; Player -> Physics: (jump)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Icon
|
||||
|
||||
(struct icon (pict scale hitbox-width-fraction hitbox-height-fraction baseline-fraction)
|
||||
#:transparent)
|
||||
|
||||
(define (icon-width i) (* (image-width (icon-pict i)) (icon-scale i)))
|
||||
(define (icon-height i) (* (image-height (icon-pict i)) (icon-scale i)))
|
||||
(define (icon-hitbox-width i) (* (icon-width i) (icon-hitbox-width-fraction i)))
|
||||
(define (icon-hitbox-height i) (* (icon-height i) (icon-hitbox-height-fraction i)))
|
||||
(define (icon-hitbox-size i) (vector (icon-hitbox-width i) (icon-hitbox-height i)))
|
||||
|
||||
(define (focus->top-left i x y)
|
||||
(vector (- x (/ (icon-hitbox-width i) 2))
|
||||
(- y (icon-hitbox-height i))))
|
||||
|
||||
(define (icon-sprite i layer pos)
|
||||
(match-define (vector x y) pos)
|
||||
(simple-sprite layer
|
||||
(- x (/ (- (icon-width i) (icon-hitbox-width i)) 2))
|
||||
(- y (- (* (icon-baseline-fraction i) (icon-height i)) (icon-hitbox-height i)))
|
||||
(icon-width i)
|
||||
(icon-height i)
|
||||
(icon-pict i)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SceneManager
|
||||
|
||||
(define (spawn-scene-manager)
|
||||
(spawn #:name 'scene-manager
|
||||
(define backdrop (rectangle 1 1 "solid" "white"))
|
||||
|
||||
(define/query-value size (vector 0 0) (inbound (window $x $y)) (vector x y))
|
||||
(define/query-set osds ($ o (on-screen-display _ _ _)) o)
|
||||
(define/query-value offset (vector 0 0) (scroll-offset $v) v)
|
||||
|
||||
(field [fullscreen? #f])
|
||||
(assert #:when (fullscreen?) (outbound 'fullscreen))
|
||||
(on (message (inbound (key-event #\f #t _)))
|
||||
(fullscreen? (not (fullscreen?))))
|
||||
|
||||
(define (compute-backdrop)
|
||||
(match-define (vector width height) (size))
|
||||
(match-define (vector ofs-x ofs-y) (offset))
|
||||
(define osd-blocks
|
||||
(for/list [(osd (in-set (osds)))]
|
||||
(match-define (on-screen-display raw-x raw-y (seal i)) osd)
|
||||
(define x (if (negative? raw-x) (+ width raw-x) raw-x))
|
||||
(define y (if (negative? raw-y) (+ height raw-y) raw-y))
|
||||
`(push-matrix (translate ,x ,y)
|
||||
(scale ,(image-width i) ,(image-height i))
|
||||
(texture ,i))))
|
||||
(scene (seal `((push-matrix
|
||||
(scale ,width ,height)
|
||||
(texture ,backdrop))
|
||||
(translate ,(- ofs-x) ,(- ofs-y))))
|
||||
(seal `((translate ,ofs-x ,ofs-y)
|
||||
,@osd-blocks))))
|
||||
(assert (outbound (compute-backdrop)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ScoreKeeper
|
||||
|
||||
(define (spawn-score-keeper)
|
||||
(spawn #:name 'score-keeper
|
||||
(field [score 0])
|
||||
(assert (current-score (score)))
|
||||
(assert (outbound
|
||||
(on-screen-display -150 10
|
||||
(seal (text (format "Score: ~a" (score)) 24 "white")))))
|
||||
(on (message (add-to-score $delta))
|
||||
(score (+ (score) delta))
|
||||
(log-info "Score increased by ~a to ~a" delta (score))
|
||||
(play-sound-sequence 270304))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; PhysicsEngine
|
||||
|
||||
(define impulse-multiplier 0.360) ;; 360 pixels per second
|
||||
(define jump-vel (vector 0 -2))
|
||||
(define gravity 0.004)
|
||||
|
||||
(define (spawn-physics-engine)
|
||||
(spawn #:name 'physics-engine
|
||||
(field [configs (hash)]
|
||||
[previous-positions (hash)]
|
||||
[previous-velocities (hash)]
|
||||
[positions (hash)]
|
||||
[velocities (hash)])
|
||||
|
||||
(during (game-piece-configuration $id $initial-position $size $attrs)
|
||||
(on-start (configs
|
||||
(hash-set (configs) id
|
||||
(game-piece-configuration id initial-position size attrs))))
|
||||
(on-stop (configs (hash-remove (configs) id))
|
||||
(positions (hash-remove (positions) id))
|
||||
(velocities (hash-remove (velocities) id)))
|
||||
(assert (position id (hash-ref (positions) id initial-position) size)))
|
||||
|
||||
(define/query-hash impulses (impulse $id $vec) id vec)
|
||||
|
||||
(define (piece-cfg id) (hash-ref (configs) id))
|
||||
(define (piece-pos which id)
|
||||
(hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id)))))
|
||||
(define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0))))
|
||||
(define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0))))
|
||||
|
||||
(define (update-piece! g new-pos new-vel)
|
||||
(positions (hash-set (positions) (game-piece-configuration-id g) new-pos))
|
||||
(velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel)))
|
||||
|
||||
(define (find-support p size which-pos)
|
||||
(match-define (vector p-left p-top) p)
|
||||
(match-define (vector p-w p-h) size)
|
||||
(define p-right (+ p-left p-w))
|
||||
(define p-bottom (+ p-top p-h))
|
||||
(for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
|
||||
(match-define (vector left top) (piece-pos which-pos id))
|
||||
(and (< (abs (- top p-bottom)) 0.5)
|
||||
(<= left p-right)
|
||||
(match (game-piece-configuration-size g)
|
||||
[(vector w h)
|
||||
(<= p-left (+ left w))])
|
||||
g)))
|
||||
|
||||
(define (segment-intersection-time p0 r q0 q1)
|
||||
;; See http://stackoverflow.com/a/565282/169231
|
||||
;; Enhanced to consider the direction of impact with the segment,
|
||||
;; too: only returns an intersection when the vector of motion is
|
||||
;; at an obtuse angle to the normal of the segment.
|
||||
(define s (v- q1 q0))
|
||||
(define rxs (vcross2 r s))
|
||||
(cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear)
|
||||
[else
|
||||
(define q-p (v- q0 p0))
|
||||
(define q-pxs (vcross2 q-p s))
|
||||
(define t (/ q-pxs rxs))
|
||||
(and (<= 0 t 1)
|
||||
(let* ((q-pxr (vcross2 q-p r))
|
||||
(u (/ q-pxr rxs)))
|
||||
(and (< 0 u 1)
|
||||
(let* ((q-norm
|
||||
(vnormalize (vector (vector-ref s 1) (- (vector-ref s 0))))))
|
||||
(and (not (positive? (vdot r q-norm)))
|
||||
(- t 0.001))))))]))
|
||||
|
||||
(define (three-corners top-left size)
|
||||
(match-define (vector w h) size)
|
||||
(values (v+ top-left (vector w 0))
|
||||
(v+ top-left size)
|
||||
(v+ top-left (vector 0 h))))
|
||||
|
||||
(define (clip-movement-by top-left moved-top-left size solid-top-left solid-size)
|
||||
(define-values (solid-top-right solid-bottom-right solid-bottom-left)
|
||||
(three-corners solid-top-left solid-size))
|
||||
(define-values (top-right bottom-right bottom-left)
|
||||
(three-corners top-left size))
|
||||
(define r (v- moved-top-left top-left))
|
||||
(define t
|
||||
(apply min
|
||||
(for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))]
|
||||
(min (or (segment-intersection-time p r solid-top-left solid-top-right) 1)
|
||||
;; TODO: some means of specifying *which edges* should appear solid.
|
||||
#;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1)
|
||||
#;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1)
|
||||
#;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1)))))
|
||||
(v+ top-left (v* r t)))
|
||||
|
||||
(define (clip-movement-by-solids p0 p1 size)
|
||||
(for/fold [(p1 p1)]
|
||||
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
|
||||
(clip-movement-by p0 p1 size
|
||||
(piece-pos previous-positions id)
|
||||
(game-piece-configuration-size g))))
|
||||
|
||||
(define (touched-during-movement? TL moved-TL size touchable-TL touchable-size)
|
||||
(define r (v- moved-TL TL))
|
||||
(if (positive? (vmag^2 r)) ;; r is nonzero, in other words
|
||||
(let ()
|
||||
(define-values (touchable-TR touchable-BR touchable-BL)
|
||||
(three-corners touchable-TL touchable-size))
|
||||
(define-values (TR BR BL)
|
||||
(three-corners TL size))
|
||||
(for/or [(p (in-list (list TL TR BR BL)))]
|
||||
(or
|
||||
(and (segment-intersection-time p r touchable-TR touchable-BR) 'right)
|
||||
(and (segment-intersection-time p r touchable-BR touchable-BL) 'bottom)
|
||||
(and (segment-intersection-time p r touchable-BL touchable-TL) 'left)
|
||||
(and (segment-intersection-time p r touchable-TL touchable-TR) 'top))))
|
||||
(let ()
|
||||
(match-define (vector left top) TL)
|
||||
(match-define (vector touchable-left touchable-top) touchable-TL)
|
||||
(match-define (vector width height) size)
|
||||
(match-define (vector touchable-width touchable-height) touchable-size)
|
||||
(and (<= left (+ touchable-left touchable-width))
|
||||
(<= top (+ touchable-top touchable-height))
|
||||
(<= touchable-left (+ left width))
|
||||
(<= touchable-top (+ top height))
|
||||
'mid))))
|
||||
|
||||
(define (touchables-touched-during-movement p0 p1 size)
|
||||
(for/fold [(ts '())]
|
||||
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'touchable)]
|
||||
(define side (touched-during-movement? p0 p1 size
|
||||
(piece-pos previous-positions id)
|
||||
(game-piece-configuration-size g)))
|
||||
(if side (cons (cons side g) ts) ts)))
|
||||
|
||||
(define (update-game-piece! elapsed-ms id)
|
||||
(define g (piece-cfg id))
|
||||
(define size (game-piece-configuration-size g))
|
||||
(define pos0 (piece-pos previous-positions id))
|
||||
(define support (find-support pos0 size previous-positions))
|
||||
|
||||
(define vel0 (piece-vel previous-velocities id))
|
||||
(define imp0 (piece-imp id))
|
||||
|
||||
(define vel1 (cond
|
||||
[(and support (not (negative? (vector-ref vel0 1))))
|
||||
(piece-vel previous-velocities (game-piece-configuration-id support))]
|
||||
[(game-piece-has-attribute? g 'massive)
|
||||
(v+ vel0 (vector 0 (* gravity elapsed-ms)))]
|
||||
[else
|
||||
vel0]))
|
||||
|
||||
(define pos1 (v+ pos0 (v* (v+ vel1 imp0) (* impulse-multiplier elapsed-ms))))
|
||||
(define final-pos (clip-movement-by-solids pos0 pos1 size))
|
||||
;; TODO: figure out how to cancel just the component of velocity blocked by the obstacle(s)
|
||||
;; - which will avoid the "sticking to the wall" artifact
|
||||
(define final-vel (if (v= pos1 final-pos) vel1 (vector 0 0))) ;; stop at collision
|
||||
(define touchables (touchables-touched-during-movement pos0 final-pos size))
|
||||
|
||||
(retract! (touching id ? ?))
|
||||
(for [(t touchables)]
|
||||
(match-define (cons side tg) t)
|
||||
(assert! (touching id (game-piece-configuration-id tg) side)))
|
||||
(update-piece! g final-pos final-vel))
|
||||
|
||||
(on (message (jump-request $id))
|
||||
(define g (piece-cfg id))
|
||||
(define pos (piece-pos positions id))
|
||||
(when (find-support pos (game-piece-configuration-size g) positions)
|
||||
(play-sound-sequence 270318)
|
||||
(update-piece! g pos jump-vel)))
|
||||
|
||||
(on (message (inbound* game-level (frame-event $counter _ $elapsed-ms _)))
|
||||
(when (zero? (modulo counter 10))
|
||||
(log-info "Instantaneous frame rate at frame ~a: ~a Hz"
|
||||
counter
|
||||
(/ 1000.0 elapsed-ms)))
|
||||
(previous-positions (positions))
|
||||
(previous-velocities (velocities))
|
||||
(for [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'mobile)]
|
||||
(update-game-piece! elapsed-ms id)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Player
|
||||
|
||||
(define player-id 'player)
|
||||
(define planetcute-scale 1/2)
|
||||
|
||||
(define (spawn-player-avatar initial-focus-x initial-focus-y)
|
||||
(spawn #:name 'player-avatar
|
||||
(define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16))
|
||||
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
|
||||
|
||||
(assert (game-piece-configuration player-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'player 'mobile 'massive)))
|
||||
|
||||
(define/query-value pos initial-top-left (position player-id $hitbox-top-left _)
|
||||
hitbox-top-left)
|
||||
(assert (outbound* game-level (icon-sprite i 0 (pos))))
|
||||
|
||||
(field [hit-points 1])
|
||||
(assert (health player-id (hit-points)))
|
||||
(stop-when-true (<= (hit-points) 0))
|
||||
(on (message (damage player-id $amount))
|
||||
(hit-points (- (hit-points) amount)))
|
||||
|
||||
(on (asserted (inbound* 2 (key-pressed #\space))) (send! (jump-request player-id)))
|
||||
(on (asserted (inbound* 2 (key-pressed #\.))) (send! (jump-request player-id)))
|
||||
|
||||
(define/query-set keys-down (inbound* 2 (key-pressed $k)) k)
|
||||
(define (any-key-down? . ks) (for/or [(k ks)] (set-member? (keys-down) k)))
|
||||
(assert (impulse player-id (vector (+ (if (any-key-down? 'left 'prior) -1 0)
|
||||
(if (any-key-down? 'right 'next) 1 0))
|
||||
0)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Ground Block
|
||||
|
||||
(define (spawn-ground-block top-left size #:color [color "purple"])
|
||||
(spawn #:name (list 'ground-block top-left size color)
|
||||
(match-define (vector x y) top-left)
|
||||
(match-define (vector w h) size)
|
||||
(define block-id (gensym 'ground-block))
|
||||
(define block-pict (rectangle w h "solid" color))
|
||||
(assert (outbound* game-level (simple-sprite 0 x y w h block-pict)))
|
||||
(assert (game-piece-configuration block-id
|
||||
top-left
|
||||
size
|
||||
(set 'solid)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Goal piece
|
||||
;;
|
||||
;; When the player touches a goal, sends LevelCompleted one layer out.
|
||||
|
||||
(define (spawn-goal-piece initial-focus-x initial-focus-y)
|
||||
(define goal-id (gensym 'goal))
|
||||
|
||||
(define i (icon key planetcute-scale 1/3 2/5 4/5))
|
||||
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
|
||||
|
||||
(spawn #:name (list 'goal-piece initial-focus-x initial-focus-y)
|
||||
(on (asserted (touching player-id goal-id _))
|
||||
(send! (outbound (level-completed))))
|
||||
(assert (game-piece-configuration goal-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'touchable)))
|
||||
(assert (outbound* game-level (icon-sprite i -1 initial-top-left)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Enemy
|
||||
|
||||
(define (spawn-enemy initial-x initial-y range-lo range-hi
|
||||
#:speed [speed 0.2]
|
||||
#:facing [initial-facing 'right])
|
||||
(spawn #:name (list 'enemy initial-x initial-y initial-facing)
|
||||
(define enemy-id (gensym 'enemy))
|
||||
(define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6))
|
||||
(define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))]))
|
||||
(define initial-top-left (focus->top-left i initial-x initial-y))
|
||||
(match-define (vector width height) (icon-hitbox-size i))
|
||||
|
||||
(assert (game-piece-configuration enemy-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'mobile 'massive 'touchable)))
|
||||
|
||||
(define/query-value current-level-size #f (level-size $v) v)
|
||||
|
||||
(define/query-value pos initial-top-left (position enemy-id $top-left _) top-left
|
||||
#:on-add (match-let (((vector left top) top-left))
|
||||
(facing (cond [(< left range-lo) 'right]
|
||||
[(> (+ left width) range-hi) 'left]
|
||||
[else (facing)]))))
|
||||
|
||||
(stop-when-true (and (current-level-size)
|
||||
(> (vector-ref (pos) 1)
|
||||
(vector-ref (current-level-size) 1))))
|
||||
|
||||
(field [facing initial-facing])
|
||||
(assert (outbound* game-level
|
||||
(icon-sprite (match (facing) ['right i] ['left i-flipped]) -1 (pos))))
|
||||
|
||||
(assert (impulse enemy-id (vector (* speed (match (facing) ['right 1] ['left -1])) 0)))
|
||||
|
||||
(stop-when (asserted (touching player-id enemy-id 'top))
|
||||
(play-sound-sequence 270325)
|
||||
(send! (outbound (add-to-score 1))))
|
||||
|
||||
(on (asserted (touching player-id enemy-id $side))
|
||||
(when (not (eq? side 'top)) (send! (damage player-id 1))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; DisplayControl
|
||||
|
||||
(define (spawn-display-controller level-size-vec)
|
||||
(match-define (vector level-width level-height) level-size-vec)
|
||||
|
||||
(spawn #:name 'display-controller
|
||||
(field [offset-pos (vector 0 0)])
|
||||
(assert (outbound* 2 (scroll-offset (offset-pos))))
|
||||
(assert (level-size level-size-vec))
|
||||
|
||||
(define/query-value window-size-vec #f (inbound* game-level (window $w $h)) (vector w h))
|
||||
|
||||
(define (compute-offset pos viewport limit)
|
||||
(min (max 0 (- pos (/ viewport 2))) (- limit viewport)))
|
||||
|
||||
(on (asserted (position player-id (vector $px $py) _))
|
||||
(when (window-size-vec)
|
||||
(match-define (vector ww wh) (window-size-vec))
|
||||
(when (> py level-height) (send! (damage player-id +inf.0)))
|
||||
(offset-pos (vector (compute-offset px ww level-width)
|
||||
(compute-offset py wh level-height)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; LevelTerminationMonitor
|
||||
;;
|
||||
;; When the player vanishes from the board, or LevelCompleted is seen,
|
||||
;; kills the dataspace.
|
||||
|
||||
(define (wait-for-level-termination)
|
||||
(spawn
|
||||
(assert (outbound (level-running)))
|
||||
(on (retracted (game-piece-configuration player-id _ _ _))
|
||||
(log-info "Player died! Terminating level.")
|
||||
(play-sound-sequence 270328)
|
||||
(quit-dataspace!))
|
||||
(on (message (inbound (level-completed)))
|
||||
(log-info "Level completed! Terminating level.")
|
||||
(play-sound-sequence 270330)
|
||||
(send! (outbound (add-to-score 100)))
|
||||
(quit-dataspace!))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; LevelSpawner
|
||||
|
||||
(define (spawn-standalone-assertions . patches)
|
||||
(spawn #:name 'standalone-assertions
|
||||
(on-start (patch! (patch-seq* patches)))))
|
||||
|
||||
(define (spawn-background-image level-size scene)
|
||||
(match-define (vector level-width level-height) level-size)
|
||||
(define scene-width (image-width scene))
|
||||
(define scene-height (image-height scene))
|
||||
(define level-aspect (/ level-width level-height))
|
||||
(define scene-aspect (/ scene-width scene-height))
|
||||
(define scale (if (> level-aspect scene-aspect) ;; level is wider, proportionally, than scene
|
||||
(/ level-width scene-width)
|
||||
(/ level-height scene-height)))
|
||||
(spawn-standalone-assertions
|
||||
(update-sprites #:meta-level game-level
|
||||
(sprite 10
|
||||
`((scale ,(* scene-width scale)
|
||||
,(* scene-height scale))
|
||||
(texture ,scene))))))
|
||||
|
||||
;; http://www.travelization.net/wp-content/uploads/2012/07/beautiful-grassland-wallpapers-1920x1080.jpg
|
||||
(define grassland-backdrop (bitmap "beautiful-grassland-wallpapers-1920x1080.jpg"))
|
||||
|
||||
(define (spawn-level #:initial-player-x [initial-player-x 50]
|
||||
#:initial-player-y [initial-player-y 50]
|
||||
#:level-size [level-size-vec (vector 4000 2000)]
|
||||
#:scene [scene grassland-backdrop]
|
||||
actions-thunk)
|
||||
(lambda ()
|
||||
(dataspace (when scene (spawn-background-image level-size-vec scene))
|
||||
(spawn-display-controller level-size-vec)
|
||||
(spawn-physics-engine)
|
||||
(spawn-player-avatar initial-player-x initial-player-y)
|
||||
(actions-thunk)
|
||||
(wait-for-level-termination))))
|
||||
|
||||
(define standard-ground-height 50)
|
||||
|
||||
(define (slab left top width #:color [color "purple"])
|
||||
(spawn-ground-block (vector left top) (vector width standard-ground-height) #:color color))
|
||||
|
||||
(define levels
|
||||
(list
|
||||
(spawn-level (lambda ()
|
||||
(slab 25 125 100)
|
||||
(slab 50 300 500)
|
||||
(spawn-enemy 100 300 50 550)
|
||||
(spawn-enemy 300 300 50 550 #:facing 'left)
|
||||
(spawn-goal-piece 570 150)
|
||||
(slab 850 300 50)
|
||||
(slab 925 400 50)
|
||||
(slab 975 500 50)
|
||||
(slab 975 600 50)
|
||||
(slab 500 600 150 #:color "orange")))
|
||||
(spawn-level (lambda ()
|
||||
(slab 25 300 500)
|
||||
(slab 500 400 500)
|
||||
(slab 1000 500 400)
|
||||
(spawn-goal-piece 1380 500)))
|
||||
(spawn-level (lambda ()
|
||||
(slab 25 300 1000)
|
||||
(spawn-enemy 600 300 25 1025 #:facing 'left)
|
||||
(spawn-goal-piece 980 300)))
|
||||
(spawn-level (lambda ()
|
||||
(spawn-goal-piece 250 280)
|
||||
(spawn-enemy 530 200 400 600)
|
||||
(spawn-enemy 500 200 -100 1000 #:facing 'left)
|
||||
(slab 400 200 200)
|
||||
(spawn-ground-block (vector 200 280) (vector 200 200) #:color "orange")
|
||||
(slab 25 300 500)
|
||||
(slab 600 1300 600)
|
||||
(slab 1150 1200 25 #:color "red")
|
||||
(for/list ((n 10))
|
||||
(slab 900 (+ 200 (* n 100)) 50)))
|
||||
)
|
||||
))
|
||||
|
||||
(define (spawn-numbered-level level-number)
|
||||
(send! (outbound* 2 (request-gc)))
|
||||
(if (< level-number (length levels))
|
||||
((list-ref levels level-number))
|
||||
(spawn-standalone-assertions
|
||||
(update-sprites #:meta-level 2
|
||||
(let ((message (text "You won!" 72 "red")))
|
||||
(simple-sprite 0
|
||||
10
|
||||
100
|
||||
(image-width message)
|
||||
(image-height message)
|
||||
message))))))
|
||||
|
||||
(define (spawn-level-spawner starting-level)
|
||||
(spawn #:name 'level-spawner
|
||||
(field [current-level starting-level]
|
||||
[level-complete? #f])
|
||||
|
||||
(on (message (level-completed)) (level-complete? #t))
|
||||
|
||||
(on (retracted (level-running))
|
||||
(current-level (if (level-complete?) (+ (current-level) 1) (current-level)))
|
||||
(level-complete? #f)
|
||||
(spawn-numbered-level (current-level)))
|
||||
|
||||
(on-start (spawn-numbered-level starting-level))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Sounds
|
||||
|
||||
(define (lookup-sound-file sound-number)
|
||||
(define sought-prefix (format "sounds/~a__" sound-number))
|
||||
(for/or [(filename (in-directory "sounds"))]
|
||||
(and (string-prefix? (path->string filename) sought-prefix)
|
||||
filename)))
|
||||
|
||||
;; TODO: make this a sound driver...
|
||||
;; TODO: ...and make sound triggering based on assertions of game
|
||||
;; state, not hardcoding in game logic
|
||||
(define (play-sound-sequence . sound-numbers)
|
||||
(thread (lambda ()
|
||||
(for [(sound-number (in-list sound-numbers))]
|
||||
(define sound-file (lookup-sound-file sound-number))
|
||||
(play-sound sound-file #f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define game-level 3) ;; used to specify meta-level to reach external I/O
|
||||
|
||||
(spawn-keyboard-integrator)
|
||||
(spawn-scene-manager)
|
||||
(dataspace (spawn-score-keeper)
|
||||
(spawn-level-spawner 0))
|
|
@ -0,0 +1,5 @@
|
|||
#lang setup/infotab
|
||||
(define deps '("syndicate"
|
||||
"base"
|
||||
"htdp-lib"
|
||||
))
|
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
@ -0,0 +1,140 @@
|
|||
Sound pack downloaded from Freesound.org
|
||||
----------------------------------------
|
||||
|
||||
This pack of sounds contains sounds by LittleRobotSoundFactory ( https://www.freesound.org/people/LittleRobotSoundFactory/ )
|
||||
You can find this pack online at: https://www.freesound.org/people/LittleRobotSoundFactory/packs/16681/
|
||||
|
||||
|
||||
License details
|
||||
---------------
|
||||
|
||||
Sampling+: http://creativecommons.org/licenses/sampling+/1.0/
|
||||
Creative Commons 0: http://creativecommons.org/publicdomain/zero/1.0/
|
||||
Attribution: http://creativecommons.org/licenses/by/3.0/
|
||||
Attribution Noncommercial: http://creativecommons.org/licenses/by-nc/3.0/
|
||||
|
||||
|
||||
Sounds in this pack
|
||||
-------------------
|
||||
|
||||
* 270344__littlerobotsoundfactory__shoot-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270344/
|
||||
* license: Attribution
|
||||
* 270343__littlerobotsoundfactory__shoot-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270343/
|
||||
* license: Attribution
|
||||
* 270342__littlerobotsoundfactory__pickup-03.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270342/
|
||||
* license: Attribution
|
||||
* 270341__littlerobotsoundfactory__pickup-04.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270341/
|
||||
* license: Attribution
|
||||
* 270340__littlerobotsoundfactory__pickup-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270340/
|
||||
* license: Attribution
|
||||
* 270339__littlerobotsoundfactory__pickup-02.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270339/
|
||||
* license: Attribution
|
||||
* 270338__littlerobotsoundfactory__open-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270338/
|
||||
* license: Attribution
|
||||
* 270337__littlerobotsoundfactory__pickup-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270337/
|
||||
* license: Attribution
|
||||
* 270336__littlerobotsoundfactory__shoot-02.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270336/
|
||||
* license: Attribution
|
||||
* 270335__littlerobotsoundfactory__shoot-03.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270335/
|
||||
* license: Attribution
|
||||
* 270334__littlerobotsoundfactory__jingle-lose-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270334/
|
||||
* license: Attribution
|
||||
* 270333__littlerobotsoundfactory__jingle-win-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270333/
|
||||
* license: Attribution
|
||||
* 270332__littlerobotsoundfactory__hit-03.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270332/
|
||||
* license: Attribution
|
||||
* 270331__littlerobotsoundfactory__jingle-achievement-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270331/
|
||||
* license: Attribution
|
||||
* 270330__littlerobotsoundfactory__jingle-achievement-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270330/
|
||||
* license: Attribution
|
||||
* 270329__littlerobotsoundfactory__jingle-lose-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270329/
|
||||
* license: Attribution
|
||||
* 270328__littlerobotsoundfactory__hero-death-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270328/
|
||||
* license: Attribution
|
||||
* 270327__littlerobotsoundfactory__hit-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270327/
|
||||
* license: Attribution
|
||||
* 270326__littlerobotsoundfactory__hit-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270326/
|
||||
* license: Attribution
|
||||
* 270325__littlerobotsoundfactory__hit-02.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270325/
|
||||
* license: Attribution
|
||||
* 270324__littlerobotsoundfactory__menu-navigate-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270324/
|
||||
* license: Attribution
|
||||
* 270323__littlerobotsoundfactory__jump-03.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270323/
|
||||
* license: Attribution
|
||||
* 270322__littlerobotsoundfactory__menu-navigate-02.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270322/
|
||||
* license: Attribution
|
||||
* 270321__littlerobotsoundfactory__menu-navigate-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270321/
|
||||
* license: Attribution
|
||||
* 270320__littlerobotsoundfactory__jump-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270320/
|
||||
* license: Attribution
|
||||
* 270319__littlerobotsoundfactory__jingle-win-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270319/
|
||||
* license: Attribution
|
||||
* 270318__littlerobotsoundfactory__jump-02.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270318/
|
||||
* license: Attribution
|
||||
* 270317__littlerobotsoundfactory__jump-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270317/
|
||||
* license: Attribution
|
||||
* 270316__littlerobotsoundfactory__open-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270316/
|
||||
* license: Attribution
|
||||
* 270315__littlerobotsoundfactory__menu-navigate-03.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270315/
|
||||
* license: Attribution
|
||||
* 270311__littlerobotsoundfactory__explosion-03.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270311/
|
||||
* license: Attribution
|
||||
* 270310__littlerobotsoundfactory__explosion-04.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270310/
|
||||
* license: Attribution
|
||||
* 270309__littlerobotsoundfactory__craft-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270309/
|
||||
* license: Attribution
|
||||
* 270308__littlerobotsoundfactory__explosion-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270308/
|
||||
* license: Attribution
|
||||
* 270307__littlerobotsoundfactory__explosion-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270307/
|
||||
* license: Attribution
|
||||
* 270306__littlerobotsoundfactory__explosion-02.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270306/
|
||||
* license: Attribution
|
||||
* 270305__littlerobotsoundfactory__climb-rope-loop-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270305/
|
||||
* license: Attribution
|
||||
* 270304__littlerobotsoundfactory__collect-point-00.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270304/
|
||||
* license: Attribution
|
||||
* 270303__littlerobotsoundfactory__collect-point-01.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270303/
|
||||
* license: Attribution
|
||||
* 270302__littlerobotsoundfactory__collect-point-02.wav
|
||||
* url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270302/
|
||||
* license: Attribution
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue