Compare commits
No commits in common. "main" and "gh-pages" have entirely different histories.
|
@ -0,0 +1 @@
|
|||
_site/
|
165
LICENSE
|
@ -1,165 +0,0 @@
|
|||
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.
|
65
README.md
|
@ -1,65 +0,0 @@
|
|||
# Syndicate: A Networked, Concurrent, Functional Programming Language
|
||||
|
||||
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
|
||||
composition of communicating processes.
|
||||
|
||||
Collaborating actors are grouped within task-specific *networks* (a.k.a.
|
||||
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.
|
||||
|
||||
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.
|
||||
Actors react to *state change notifications* reporting changes in a
|
||||
dataspace, including new subscriptions created by peers and removal of
|
||||
subscriptions when a peer exits or crashes. State change notifications
|
||||
serve to communicate changes in demand for and supply of services,
|
||||
both within a single network and across nested layers of
|
||||
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.
|
||||
|
||||
## Contents
|
||||
|
||||
This repository contains
|
||||
|
||||
- a [Racket](http://racket-lang.org/) implementation of Syndicate
|
||||
(plus auxiliary modules) in `racket/syndicate/`
|
||||
|
||||
- an
|
||||
[ECMAScript 5](http://www.ecma-international.org/publications/standards/Ecma-262.htm)
|
||||
implementation of Syndicate in `js/`
|
||||
|
||||
- larger example programs:
|
||||
|
||||
- `examples/platformer`, a 2D Platform game written in Syndicate
|
||||
for Racket.
|
||||
|
||||
- `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.
|
||||
|
||||
- a sketch of a Haskell implementation of the core routing structures
|
||||
of Syndicate in `hs/`
|
||||
|
||||
## Copyright and License
|
||||
|
||||
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018.
|
||||
|
||||
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.
|
||||
|
||||
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.
|
||||
|
||||
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/>.
|
|
@ -0,0 +1,19 @@
|
|||
defaults:
|
||||
-
|
||||
scope:
|
||||
path: ""
|
||||
values:
|
||||
layout: page
|
||||
|
||||
title: "Dataspaces"
|
||||
subtitle: "and Conversational Concurrency"
|
||||
|
||||
# syn·di·cate
|
||||
# a language for interactive programs"
|
||||
|
||||
markdown: kramdown
|
||||
highlighter: rouge
|
||||
|
||||
kramdown:
|
||||
input: GFM
|
||||
hard_wrap: false
|
|
@ -0,0 +1,9 @@
|
|||
```javascript
|
||||
spawn {
|
||||
field this.balance = 0;
|
||||
assert account(this.balance);
|
||||
on message deposit($amount) {
|
||||
this.balance += amount;
|
||||
}
|
||||
}
|
||||
```
|
|
@ -0,0 +1,7 @@
|
|||
```javascript
|
||||
spawn {
|
||||
on asserted account($balance) {
|
||||
console.log("Balance:", balance);
|
||||
}
|
||||
}
|
||||
```
|
|
@ -0,0 +1,7 @@
|
|||
```racket
|
||||
(spawn
|
||||
(field [balance 0])
|
||||
(assert (account (balance)))
|
||||
(on (message (deposit $amount))
|
||||
(balance (+ (balance) amount))))
|
||||
```
|
|
@ -0,0 +1,5 @@
|
|||
```racket
|
||||
(spawn
|
||||
(on (asserted (account $balance))
|
||||
(printf "Balance: ~a\n" balance)))
|
||||
```
|
|
@ -0,0 +1,4 @@
|
|||
---
|
||||
layout: skeleton
|
||||
---
|
||||
{{ content }}
|
|
@ -0,0 +1,48 @@
|
|||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
||||
<title>{% if page.title %}{{ page.title }}—{% else %}{% endif %}{{ site.title }}</title>
|
||||
<link rel="stylesheet" type="text/css" href="{{ site.baseurl }}/css/normalize.css" title="stylesheet">
|
||||
<link rel="stylesheet" type="text/css" href="{{ site.baseurl }}/css/style.css" title="stylesheet">
|
||||
{% for sheet in page.stylesheets %}
|
||||
<link rel="stylesheet" type="text/css" href="{{ site.baseurl }}/{{ sheet }}">
|
||||
{% endfor %}
|
||||
<meta name="author" content="Tony Garnock-Jones">
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1.0">
|
||||
{% if page.feed %}
|
||||
<link rel="alternate" type="application/atom+xml" href="{{ page.feed }}" title="Atom feed" />
|
||||
{% endif %}
|
||||
</head>
|
||||
<body class="{{ page.class }}">
|
||||
<header>
|
||||
<div class="outer-wrapper">
|
||||
<div class="inner-wrapper">
|
||||
<h1><a href="{{ site.baseurl }}/"><span class="title">{{ site.title }}</span></a> <span class="subtitle">{{ site.subtitle }}</span></h1>
|
||||
<nav>
|
||||
<ul>
|
||||
<li><a href="{{ site.baseurl }}/">Home</a></li>
|
||||
<li><a href="{{ site.baseurl }}/#documentation">Docs</a></li>
|
||||
<li><a href="{{ site.baseurl }}/examples/">Demos</a></li>
|
||||
<li><a href="{{ site.baseurl }}/install/">Installing Syndicate</a></li>
|
||||
<li><a href="https://github.com/syndicate-lang/">Github</a></li>
|
||||
</ul>
|
||||
</nav>
|
||||
</div>
|
||||
</div>
|
||||
</header>
|
||||
<main class="content">
|
||||
{{ content }}
|
||||
<div class="clear"></div>
|
||||
</main>
|
||||
<footer>
|
||||
<div class="outer-wrapper">
|
||||
<div class="inner-wrapper">
|
||||
<p>
|
||||
Copyright © 2009–2021 <a href="https://leastfixedpoint.com/">Tony Garnock-Jones</a>
|
||||
</p>
|
||||
</div>
|
||||
</div>
|
||||
</footer>
|
||||
</body>
|
||||
</html>
|
|
@ -0,0 +1,39 @@
|
|||
---
|
||||
layout:
|
||||
---
|
||||
|
||||
@font-face {
|
||||
font-family: "Bebas Neue";
|
||||
src: url("/fonts/BebasNeue-Regular.ttf");
|
||||
}
|
||||
|
||||
@font-face {
|
||||
font-family: "Libre Barcode 39 Text";
|
||||
src: url("/fonts/LibreBarcode39Text-Regular.ttf");
|
||||
}
|
||||
|
||||
@font-face {
|
||||
font-family: "Major Mono Display Text";
|
||||
src: url("/fonts/MajorMonoDisplay-Regular.ttf");
|
||||
}
|
||||
|
||||
@font-face {
|
||||
font-family: "Inconsolata Regular";
|
||||
src: url("/fonts/Inconsolata-Regular.ttf");
|
||||
}
|
||||
|
||||
@font-face { font-family: "IBM Plex Sans"; font-weight: 300; font-style: normal; src: url("/fonts/IBMPlexSans-Light.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Sans"; font-weight: 300; font-style: italic; src: url("/fonts/IBMPlexSans-LightItalic.ttf"); }
|
||||
|
||||
@font-face { font-family: "IBM Plex Mono"; font-weight: 300; font-style: normal; src: url("/fonts/IBMPlexMono-Light.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Mono"; font-weight: 500; font-style: normal; src: url("/fonts/IBMPlexMono-Medium.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Mono"; font-weight: 600; font-style: normal; src: url("/fonts/IBMPlexMono-SemiBold.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Mono"; font-weight: 300; font-style: italic; src: url("/fonts/IBMPlexMono-LightItalic.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Mono"; font-weight: 500; font-style: italic; src: url("/fonts/IBMPlexMono-MediumItalic.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Mono"; font-weight: 600; font-style: italic; src: url("/fonts/IBMPlexMono-SemiBoldItalic.ttf"); }
|
||||
|
||||
@font-face { font-family: "IBM Plex Serif"; font-weight: 300; font-style: normal; src: url("/fonts/IBMPlexSerif-Light.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Serif"; font-weight: 400; font-style: normal; src: url("/fonts/IBMPlexSerif-Regular.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Serif"; font-weight: 500; font-style: normal; src: url("/fonts/IBMPlexSerif-Medium.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Serif"; font-weight: 300; font-style: italic; src: url("/fonts/IBMPlexSerif-LightItalic.ttf"); }
|
||||
@font-face { font-family: "IBM Plex Serif"; font-weight: 500; font-style: italic; src: url("/fonts/IBMPlexSerif-MediumItalic.ttf"); }
|
|
@ -0,0 +1,349 @@
|
|||
/*! normalize.css v8.0.1 | MIT License | github.com/necolas/normalize.css */
|
||||
|
||||
/* Document
|
||||
========================================================================== */
|
||||
|
||||
/**
|
||||
* 1. Correct the line height in all browsers.
|
||||
* 2. Prevent adjustments of font size after orientation changes in iOS.
|
||||
*/
|
||||
|
||||
html {
|
||||
line-height: 1.15; /* 1 */
|
||||
-webkit-text-size-adjust: 100%; /* 2 */
|
||||
}
|
||||
|
||||
/* Sections
|
||||
========================================================================== */
|
||||
|
||||
/**
|
||||
* Remove the margin in all browsers.
|
||||
*/
|
||||
|
||||
body {
|
||||
margin: 0;
|
||||
}
|
||||
|
||||
/**
|
||||
* Render the `main` element consistently in IE.
|
||||
*/
|
||||
|
||||
main {
|
||||
display: block;
|
||||
}
|
||||
|
||||
/**
|
||||
* Correct the font size and margin on `h1` elements within `section` and
|
||||
* `article` contexts in Chrome, Firefox, and Safari.
|
||||
*/
|
||||
|
||||
h1 {
|
||||
font-size: 2em;
|
||||
margin: 0.67em 0;
|
||||
}
|
||||
|
||||
/* Grouping content
|
||||
========================================================================== */
|
||||
|
||||
/**
|
||||
* 1. Add the correct box sizing in Firefox.
|
||||
* 2. Show the overflow in Edge and IE.
|
||||
*/
|
||||
|
||||
hr {
|
||||
box-sizing: content-box; /* 1 */
|
||||
height: 0; /* 1 */
|
||||
overflow: visible; /* 2 */
|
||||
}
|
||||
|
||||
/**
|
||||
* 1. Correct the inheritance and scaling of font size in all browsers.
|
||||
* 2. Correct the odd `em` font sizing in all browsers.
|
||||
*/
|
||||
|
||||
pre {
|
||||
font-family: monospace, monospace; /* 1 */
|
||||
font-size: 1em; /* 2 */
|
||||
}
|
||||
|
||||
/* Text-level semantics
|
||||
========================================================================== */
|
||||
|
||||
/**
|
||||
* Remove the gray background on active links in IE 10.
|
||||
*/
|
||||
|
||||
a {
|
||||
background-color: transparent;
|
||||
}
|
||||
|
||||
/**
|
||||
* 1. Remove the bottom border in Chrome 57-
|
||||
* 2. Add the correct text decoration in Chrome, Edge, IE, Opera, and Safari.
|
||||
*/
|
||||
|
||||
abbr[title] {
|
||||
border-bottom: none; /* 1 */
|
||||
text-decoration: underline; /* 2 */
|
||||
text-decoration: underline dotted; /* 2 */
|
||||
}
|
||||
|
||||
/**
|
||||
* Add the correct font weight in Chrome, Edge, and Safari.
|
||||
*/
|
||||
|
||||
b,
|
||||
strong {
|
||||
font-weight: bolder;
|
||||
}
|
||||
|
||||
/**
|
||||
* 1. Correct the inheritance and scaling of font size in all browsers.
|
||||
* 2. Correct the odd `em` font sizing in all browsers.
|
||||
*/
|
||||
|
||||
code,
|
||||
kbd,
|
||||
samp {
|
||||
font-family: monospace, monospace; /* 1 */
|
||||
font-size: 1em; /* 2 */
|
||||
}
|
||||
|
||||
/**
|
||||
* Add the correct font size in all browsers.
|
||||
*/
|
||||
|
||||
small {
|
||||
font-size: 80%;
|
||||
}
|
||||
|
||||
/**
|
||||
* Prevent `sub` and `sup` elements from affecting the line height in
|
||||
* all browsers.
|
||||
*/
|
||||
|
||||
sub,
|
||||
sup {
|
||||
font-size: 75%;
|
||||
line-height: 0;
|
||||
position: relative;
|
||||
vertical-align: baseline;
|
||||
}
|
||||
|
||||
sub {
|
||||
bottom: -0.25em;
|
||||
}
|
||||
|
||||
sup {
|
||||
top: -0.5em;
|
||||
}
|
||||
|
||||
/* Embedded content
|
||||
========================================================================== */
|
||||
|
||||
/**
|
||||
* Remove the border on images inside links in IE 10.
|
||||
*/
|
||||
|
||||
img {
|
||||
border-style: none;
|
||||
}
|
||||
|
||||
/* Forms
|
||||
========================================================================== */
|
||||
|
||||
/**
|
||||
* 1. Change the font styles in all browsers.
|
||||
* 2. Remove the margin in Firefox and Safari.
|
||||
*/
|
||||
|
||||
button,
|
||||
input,
|
||||
optgroup,
|
||||
select,
|
||||
textarea {
|
||||
font-family: inherit; /* 1 */
|
||||
font-size: 100%; /* 1 */
|
||||
line-height: 1.15; /* 1 */
|
||||
margin: 0; /* 2 */
|
||||
}
|
||||
|
||||
/**
|
||||
* Show the overflow in IE.
|
||||
* 1. Show the overflow in Edge.
|
||||
*/
|
||||
|
||||
button,
|
||||
input { /* 1 */
|
||||
overflow: visible;
|
||||
}
|
||||
|
||||
/**
|
||||
* Remove the inheritance of text transform in Edge, Firefox, and IE.
|
||||
* 1. Remove the inheritance of text transform in Firefox.
|
||||
*/
|
||||
|
||||
button,
|
||||
select { /* 1 */
|
||||
text-transform: none;
|
||||
}
|
||||
|
||||
/**
|
||||
* Correct the inability to style clickable types in iOS and Safari.
|
||||
*/
|
||||
|
||||
button,
|
||||
[type="button"],
|
||||
[type="reset"],
|
||||
[type="submit"] {
|
||||
-webkit-appearance: button;
|
||||
}
|
||||
|
||||
/**
|
||||
* Remove the inner border and padding in Firefox.
|
||||
*/
|
||||
|
||||
button::-moz-focus-inner,
|
||||
[type="button"]::-moz-focus-inner,
|
||||
[type="reset"]::-moz-focus-inner,
|
||||
[type="submit"]::-moz-focus-inner {
|
||||
border-style: none;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
/**
|
||||
* Restore the focus styles unset by the previous rule.
|
||||
*/
|
||||
|
||||
button:-moz-focusring,
|
||||
[type="button"]:-moz-focusring,
|
||||
[type="reset"]:-moz-focusring,
|
||||
[type="submit"]:-moz-focusring {
|
||||
outline: 1px dotted ButtonText;
|
||||
}
|
||||
|
||||
/**
|
||||
* Correct the padding in Firefox.
|
||||
*/
|
||||
|
||||
fieldset {
|
||||
padding: 0.35em 0.75em 0.625em;
|
||||
}
|
||||
|
||||
/**
|
||||
* 1. Correct the text wrapping in Edge and IE.
|
||||
* 2. Correct the color inheritance from `fieldset` elements in IE.
|
||||
* 3. Remove the padding so developers are not caught out when they zero out
|
||||
* `fieldset` elements in all browsers.
|
||||
*/
|
||||
|
||||
legend {
|
||||
box-sizing: border-box; /* 1 */
|
||||
color: inherit; /* 2 */
|
||||
display: table; /* 1 */
|
||||
max-width: 100%; /* 1 */
|
||||
padding: 0; /* 3 */
|
||||
white-space: normal; /* 1 */
|
||||
}
|
||||
|
||||
/**
|
||||
* Add the correct vertical alignment in Chrome, Firefox, and Opera.
|
||||
*/
|
||||
|
||||
progress {
|
||||
vertical-align: baseline;
|
||||
}
|
||||
|
||||
/**
|
||||
* Remove the default vertical scrollbar in IE 10+.
|
||||
*/
|
||||
|
||||
textarea {
|
||||
overflow: auto;
|
||||
}
|
||||
|
||||
/**
|
||||
* 1. Add the correct box sizing in IE 10.
|
||||
* 2. Remove the padding in IE 10.
|
||||
*/
|
||||
|
||||
[type="checkbox"],
|
||||
[type="radio"] {
|
||||
box-sizing: border-box; /* 1 */
|
||||
padding: 0; /* 2 */
|
||||
}
|
||||
|
||||
/**
|
||||
* Correct the cursor style of increment and decrement buttons in Chrome.
|
||||
*/
|
||||
|
||||
[type="number"]::-webkit-inner-spin-button,
|
||||
[type="number"]::-webkit-outer-spin-button {
|
||||
height: auto;
|
||||
}
|
||||
|
||||
/**
|
||||
* 1. Correct the odd appearance in Chrome and Safari.
|
||||
* 2. Correct the outline style in Safari.
|
||||
*/
|
||||
|
||||
[type="search"] {
|
||||
-webkit-appearance: textfield; /* 1 */
|
||||
outline-offset: -2px; /* 2 */
|
||||
}
|
||||
|
||||
/**
|
||||
* Remove the inner padding in Chrome and Safari on macOS.
|
||||
*/
|
||||
|
||||
[type="search"]::-webkit-search-decoration {
|
||||
-webkit-appearance: none;
|
||||
}
|
||||
|
||||
/**
|
||||
* 1. Correct the inability to style clickable types in iOS and Safari.
|
||||
* 2. Change font properties to `inherit` in Safari.
|
||||
*/
|
||||
|
||||
::-webkit-file-upload-button {
|
||||
-webkit-appearance: button; /* 1 */
|
||||
font: inherit; /* 2 */
|
||||
}
|
||||
|
||||
/* Interactive
|
||||
========================================================================== */
|
||||
|
||||
/*
|
||||
* Add the correct display in Edge, IE 10+, and Firefox.
|
||||
*/
|
||||
|
||||
details {
|
||||
display: block;
|
||||
}
|
||||
|
||||
/*
|
||||
* Add the correct display in all browsers.
|
||||
*/
|
||||
|
||||
summary {
|
||||
display: list-item;
|
||||
}
|
||||
|
||||
/* Misc
|
||||
========================================================================== */
|
||||
|
||||
/**
|
||||
* Add the correct display in IE 10+.
|
||||
*/
|
||||
|
||||
template {
|
||||
display: none;
|
||||
}
|
||||
|
||||
/**
|
||||
* Add the correct display in IE 10.
|
||||
*/
|
||||
|
||||
[hidden] {
|
||||
display: none;
|
||||
}
|
|
@ -0,0 +1,302 @@
|
|||
---
|
||||
layout:
|
||||
|
||||
display-font: '"Bebas Neue", sans'
|
||||
nav-font: '"Inconsolata Regular"'
|
||||
|
||||
horizontal-border-width: "0.25rem"
|
||||
|
||||
heading-font: '"IBM Plex Serif", serif'
|
||||
heading-font-small: '"IBM Plex Mono", monospace'
|
||||
skinny-header-margin: "1rem"
|
||||
|
||||
body-font: '"IBM Plex Sans", sans'
|
||||
body-margin: "2rem"
|
||||
body-lhs: "10rem"
|
||||
body-lhs-inset: "8rem"
|
||||
body-lhs-border: "1rem"
|
||||
body-lhs-border-indent: "7rem"
|
||||
|
||||
code-font: '"IBM Plex Mono", monospace'
|
||||
---
|
||||
|
||||
@import 'font-definitions.css';
|
||||
|
||||
html, body, * { box-sizing: border-box; }
|
||||
|
||||
html {
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
font-size: 14pt;
|
||||
}
|
||||
|
||||
body {
|
||||
font-family: {{ page.body-font }};
|
||||
font-weight: 300;
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
background: white;
|
||||
}
|
||||
|
||||
main {
|
||||
max-width: 960px;
|
||||
clear: both;
|
||||
margin: {{ page.body-margin }};
|
||||
}
|
||||
|
||||
.clear {
|
||||
clear: both;
|
||||
}
|
||||
|
||||
main ul.boxes {
|
||||
display: flex;
|
||||
flex-direction: column;
|
||||
flex-wrap: wrap;
|
||||
justify-content: flex-start;
|
||||
align-items: stretch;
|
||||
align-content: stretch;
|
||||
margin: -0.5rem -1.5rem 1rem;
|
||||
margin-bottom: 1rem;
|
||||
padding: 0;
|
||||
}
|
||||
|
||||
main ul.boxes > li {
|
||||
background: white;
|
||||
display: flex;
|
||||
flex-direction: column;
|
||||
border: solid black;
|
||||
border-width: {{ page.horizontal-border-width }};
|
||||
margin: 0.5rem;
|
||||
padding: 0 0.75rem;
|
||||
}
|
||||
|
||||
main ul.boxes > li > * {
|
||||
margin: 0.5rem 0;
|
||||
}
|
||||
|
||||
main ul.boxes > li > *.read-more {
|
||||
display: flex;
|
||||
align-items: flex-end;
|
||||
|
||||
align-self: flex-end;
|
||||
flex-grow: 1;
|
||||
}
|
||||
|
||||
main ul.boxes > li > h1 {
|
||||
font-family: {{ page.display-font }};
|
||||
font-style: normal;
|
||||
font-weight: normal;
|
||||
border-bottom: solid black {{ page.horizontal-border-width }};
|
||||
background: lightcyan;
|
||||
margin: 0 -0.75rem;
|
||||
}
|
||||
|
||||
main ul.boxes > li > h1 > a {
|
||||
display: block;
|
||||
padding: 0.25rem 0.75rem 0;
|
||||
}
|
||||
|
||||
main > hr {
|
||||
background: white;
|
||||
height: 0;
|
||||
border: none;
|
||||
border-top: solid black 0.125rem;
|
||||
border-bottom: solid black 0.125rem;
|
||||
margin: 2rem auto;
|
||||
width: calc({{ page.body-margin }} + {{ page.body-lhs-border }});
|
||||
}
|
||||
|
||||
.logos {
|
||||
display: flex;
|
||||
flex-wrap: wrap;
|
||||
margin-left: -0.25rem;
|
||||
margin-top: -0.25rem;
|
||||
}
|
||||
|
||||
.logos > * {
|
||||
flex-grow: 1;
|
||||
flex-shrink: 1;
|
||||
min-width: 64px;
|
||||
width: auto;
|
||||
height: auto;
|
||||
margin-left: 0.25rem;
|
||||
margin-top: 0.25rem;
|
||||
}
|
||||
|
||||
.logos3 > * { flex-basis: calc(100% / 3 - 0.25rem); }
|
||||
.logos2 > * { flex-basis: calc(100% / 2 - 0.25rem); }
|
||||
|
||||
pre {
|
||||
font-size: 0.9rem;
|
||||
}
|
||||
|
||||
.frontpage_code_examples {
|
||||
margin: 0 -{{ page.body-margin }};
|
||||
padding: 0 {{ page.body-lhs-border }};
|
||||
}
|
||||
|
||||
*:target {
|
||||
background: yellow;
|
||||
}
|
||||
|
||||
h1, h2, h3, h4, h5, h6 {
|
||||
font-family: {{ page.heading-font }};
|
||||
font-style: italic;
|
||||
font-weight: 300;
|
||||
clear: both;
|
||||
}
|
||||
|
||||
h1 a {
|
||||
text-decoration: none;
|
||||
color: inherit;
|
||||
}
|
||||
|
||||
h1 { font-size: 1.56rem; }
|
||||
h2 { font-size: 1.25rem; }
|
||||
h3, h4, h5, h6 { font-size: 1rem; }
|
||||
|
||||
pre, code {
|
||||
font-family: {{ page.code-font }};
|
||||
}
|
||||
|
||||
h1 code, h2 code, h3 code, h4 code, h5 code, h6 code {
|
||||
font-family: inherit;
|
||||
}
|
||||
|
||||
header {
|
||||
display: flex;
|
||||
margin-top: 0;
|
||||
margin-bottom: 0;
|
||||
border-bottom: solid black {{ page.horizontal-border-width }};
|
||||
}
|
||||
|
||||
header .outer-wrapper {
|
||||
border-left: solid magenta {{ page.skinny-header-margin }};
|
||||
}
|
||||
|
||||
header .inner-wrapper {
|
||||
padding: 0 {{ page.skinny-header-margin }};
|
||||
}
|
||||
|
||||
header h1 {
|
||||
font-family: {{ page.display-font }};
|
||||
font-style: normal;
|
||||
font-weight: normal;
|
||||
font-size: 4rem;
|
||||
margin-top: 1rem;
|
||||
margin-bottom: 1rem;
|
||||
line-height: 1;
|
||||
}
|
||||
|
||||
header h1 span {
|
||||
display: inline-block;
|
||||
}
|
||||
|
||||
header h1 span.subtitle {
|
||||
font-size: 2rem;
|
||||
}
|
||||
|
||||
nav > ul {
|
||||
display: flex;
|
||||
flex-direction: row;
|
||||
flex-wrap: wrap;
|
||||
padding: 0;
|
||||
margin: 0;
|
||||
margin-bottom: 0.5rem;
|
||||
}
|
||||
|
||||
nav > ul > li {
|
||||
display: block;
|
||||
margin: 0;
|
||||
padding: 0;
|
||||
margin-right: 1rem;
|
||||
}
|
||||
|
||||
nav a {
|
||||
text-decoration: none;
|
||||
color: inherit;
|
||||
}
|
||||
|
||||
footer {
|
||||
border-top: solid black 0.25rem;
|
||||
clear: both;
|
||||
font-size: 0.5rem;
|
||||
text-align: right;
|
||||
}
|
||||
|
||||
footer .outer-wrapper {
|
||||
padding: 2rem 0 0.5rem;
|
||||
border-right: solid cyan {{ page.skinny-header-margin }};
|
||||
}
|
||||
|
||||
footer .inner-wrapper {
|
||||
padding: 0 {{ page.skinny-header-margin }};
|
||||
}
|
||||
|
||||
img {
|
||||
max-width: 100%;
|
||||
}
|
||||
|
||||
@media all and (min-width: 960px) {
|
||||
html {
|
||||
font-size: 15pt;
|
||||
}
|
||||
|
||||
header {
|
||||
margin: 0;
|
||||
margin-right: {{ page.body-margin }};
|
||||
}
|
||||
|
||||
header .outer-wrapper {
|
||||
display: flex;
|
||||
width: 100%;
|
||||
margin: 0;
|
||||
min-height: {{ page.body-lhs-inset }};
|
||||
border-left: solid magenta {{ page.body-lhs-inset }};
|
||||
align-items: flex-end;
|
||||
}
|
||||
|
||||
header .inner-wrapper {
|
||||
width: 100%;
|
||||
padding-left: {{ page.body-margin }};
|
||||
flex-direction: row;
|
||||
}
|
||||
|
||||
footer .outer-wrapper {
|
||||
border-right: solid cyan 4rem;
|
||||
}
|
||||
|
||||
main {
|
||||
border-left: solid black {{ page.body-lhs-border }};
|
||||
padding: 1rem 0 1rem {{ page.body-margin }};
|
||||
margin: 0 0 0 {{ page.body-lhs-border-indent }};
|
||||
}
|
||||
|
||||
main ul.boxes {
|
||||
flex-direction: row;
|
||||
margin: -0.5rem -4.75rem -0.5rem -9.5rem;
|
||||
}
|
||||
|
||||
main ul.boxes > li {
|
||||
width: calc(100%/3 - 2 * 0.5rem);
|
||||
}
|
||||
|
||||
main > hr {
|
||||
margin-left: calc(-{{ page.body-margin }} - {{ page.body-lhs-border }});
|
||||
height: 1rem;
|
||||
}
|
||||
|
||||
.rightfloat { float: right; margin-left: 1rem; margin-bottom: 1rem; }
|
||||
.leftfloat { float: left; margin-right: 1rem; margin-bottom: 1rem; }
|
||||
|
||||
.frontpage_code_examples {
|
||||
margin: 0;
|
||||
display: flex;
|
||||
align-items: stretch;
|
||||
}
|
||||
|
||||
.frontpage_code_examples > div {
|
||||
padding: 0 0.5rem;
|
||||
flex: 1;
|
||||
}
|
||||
}
|
|
@ -1,57 +0,0 @@
|
|||
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"];
|
||||
|
||||
}
|
|
@ -1,388 +0,0 @@
|
|||
# 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.
|
Before Width: | Height: | Size: 69 KiB |
|
@ -0,0 +1,13 @@
|
|||
"use strict";
|
||||
new Syndicate.Ground(function () {
|
||||
Syndicate.UI.spawnUIDriver();
|
||||
|
||||
Syndicate.Actor.spawnActor(function() { Syndicate.Actor.Facet.build(function () { {
|
||||
var ui = new Syndicate.UI.Anchor();
|
||||
Syndicate.Actor.declareField(this, "counter", 0);
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return Syndicate.Patch.assert(ui.html('#button-label', '' + this.counter), 0); }));
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(Syndicate.UI.globalEvent('#counter', 'click', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: Syndicate.UI.globalEvent('#counter', 'click', _), metalevel: 0 }; }), (function() {
|
||||
this.counter++;
|
||||
}));
|
||||
} }); });
|
||||
}).startStepping();
|
|
@ -0,0 +1,26 @@
|
|||
"use strict";
|
||||
document.addEventListener('DOMContentLoaded', function () {
|
||||
var G = new Syndicate.Ground(function () {
|
||||
Syndicate.UI.spawnUIDriver();
|
||||
|
||||
Syndicate.Actor.spawnActor(function() { Syndicate.Actor.Facet.build(function () { {
|
||||
var ui = new Syndicate.UI.Anchor();
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "asserted", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(Syndicate.observe('bump_count'), 0); }), (function() { var _ = Syndicate.__; return { assertion: Syndicate.observe('bump_count'), metalevel: 0 }; }), (function() {
|
||||
var _cachedAssertion1522142575909_0 = (function() { var _ = Syndicate.__; return Syndicate.observe('bump_count'); }).call(this);
|
||||
{ Syndicate.Actor.Facet.build(function () { { // wait for the worker to boot and start listening
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return Syndicate.Patch.assert(ui.html('#clicker-holder',
|
||||
'<button><span style="font-style: italic">Click me!</span></button>'), 0); }));
|
||||
}
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, true, "retracted", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(_cachedAssertion1522142575909_0, 0); }), (function() { var _ = Syndicate.__; return { assertion: _cachedAssertion1522142575909_0, metalevel: 0 }; }), (function() {})); }); }}));
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(Syndicate.UI.globalEvent('#clicker-holder > button', 'click', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: Syndicate.UI.globalEvent('#clicker-holder > button', 'click', _), metalevel: 0 }; }), (function() {
|
||||
Syndicate.Dataspace.send('bump_count');
|
||||
}));
|
||||
} }); });
|
||||
|
||||
Syndicate.Dataspace.spawn(new Syndicate.Worker('worker.expanded.js'));
|
||||
}).startStepping();
|
||||
|
||||
G.dataspace.setOnStateChange(function (mux, patch) {
|
||||
document.getElementById('spy-holder').innerText = Syndicate.prettyTrie(mux.routingTable);
|
||||
});
|
||||
});
|
|
@ -0,0 +1,17 @@
|
|||
"use strict";
|
||||
importScripts("../../dist/syndicate.js");
|
||||
|
||||
var G = new Syndicate.WorkerGround(function () {
|
||||
Syndicate.Actor.spawnActor(function() { Syndicate.Actor.Facet.build(function () { {
|
||||
var ui = new Syndicate.UI.Anchor();
|
||||
Syndicate.Actor.declareField(this, "counter", 0);
|
||||
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return Syndicate.Patch.assert(ui.html('#counter-holder', '<div><p>The current count is: '+this.counter+'</p></div>'), 1); }));
|
||||
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub('bump_count', 1); }), (function() { var _ = Syndicate.__; return { assertion: 'bump_count', metalevel: 1 }; }), (function() {
|
||||
this.counter++;
|
||||
}));
|
||||
} }); });
|
||||
});
|
||||
|
||||
G.startStepping();
|
|
@ -111,7 +111,7 @@ that he and his collaborators have been developing.
|
|||
|
||||
## TodoMVC
|
||||
|
||||
<img src="todo/todomvc-screenshot.png" alt="TodoMVC Example" class="rightfloat">
|
||||
<div class="rightfloat"><img src="todo/todomvc-screenshot.png" alt="TodoMVC Example"></div>
|
||||
|
||||
An implementation of a
|
||||
[standard challenge problem](http://todomvc.com/) for web programming:
|
Before Width: | Height: | Size: 1.6 MiB After Width: | Height: | Size: 1.6 MiB |
Before Width: | Height: | Size: 10 KiB After Width: | Height: | Size: 10 KiB |
Before Width: | Height: | Size: 7.3 KiB After Width: | Height: | Size: 7.3 KiB |
Before Width: | Height: | Size: 8.5 KiB After Width: | Height: | Size: 8.5 KiB |
Before Width: | Height: | Size: 207 KiB After Width: | Height: | Size: 207 KiB |
Before Width: | Height: | Size: 49 KiB After Width: | Height: | Size: 49 KiB |
|
@ -1,2 +0,0 @@
|
|||
scratch/
|
||||
compiled/
|
|
@ -1,7 +0,0 @@
|
|||
all:
|
||||
|
||||
run:
|
||||
raco make main.rkt && racket main.rkt
|
||||
|
||||
clean:
|
||||
rm -rf compiled
|
|
@ -1,17 +0,0 @@
|
|||
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??
|
|
@ -1,24 +0,0 @@
|
|||
#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))))
|
|
@ -1,14 +0,0 @@
|
|||
#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)))
|
|
@ -1,7 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require/activate syndicate/reload)
|
||||
|
||||
(spawn-reloader "config.rkt")
|
||||
(spawn-reloader "session.rkt")
|
||||
(spawn-reloader "channel.rkt")
|
|
@ -1,93 +0,0 @@
|
|||
#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"))
|
|
@ -1,30 +0,0 @@
|
|||
#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]))
|
|
@ -1,177 +0,0 @@
|
|||
#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,150 @@
|
|||
"use strict";
|
||||
var locationRecord = Syndicate.Struct.makeConstructor('location', ["id","email","timestamp","lat","lng"]);
|
||||
var findMarker = Syndicate.Struct.makeConstructor("findMarker", ["id"]);
|
||||
|
||||
var brokerConnection = Syndicate.Broker.brokerConnection;
|
||||
var toBroker = Syndicate.Broker.toBroker;
|
||||
var fromBroker = Syndicate.Broker.fromBroker;
|
||||
|
||||
var G = new Syndicate.Ground(function () {
|
||||
Syndicate.UI.spawnUIDriver();
|
||||
Syndicate.Timer.spawnTimerDriver();
|
||||
Syndicate.Broker.spawnBrokerClientDriver();
|
||||
|
||||
Syndicate.Actor.spawnActor(function() { Syndicate.Actor.Facet.build(function () { {
|
||||
var id = Syndicate.RandomID.randomId(4, true);
|
||||
|
||||
var email_element = document.getElementById('my_email');
|
||||
if (localStorage.my_email) {
|
||||
email_element.value = localStorage.my_email;
|
||||
} else {
|
||||
localStorage.my_email = email_element.value = id;
|
||||
}
|
||||
|
||||
var group_element = document.getElementById('group');
|
||||
var url_group_match = /group=(.*)$/.exec(document.location.search || '');
|
||||
if (url_group_match) {
|
||||
localStorage.group = group_element.value = url_group_match[1];
|
||||
} else if (localStorage.group) {
|
||||
group_element.value = localStorage.group;
|
||||
} else {
|
||||
localStorage.group = group_element.value = 'Public';
|
||||
}
|
||||
|
||||
var mapInitialized = false;
|
||||
var map = new google.maps.Map(document.getElementById('map'), {
|
||||
center: {lat: 42, lng: -71},
|
||||
zoom: 18
|
||||
});
|
||||
|
||||
var infoWindow = new google.maps.InfoWindow();
|
||||
var geocoder = new google.maps.Geocoder();
|
||||
|
||||
var wsurl_base = 'wss://demo-broker.syndicate-lang.org:8443/location/';
|
||||
Syndicate.Actor.declareField(this, "wsurl", wsurl_base + group_element.value.trim());
|
||||
|
||||
var watchId = ('geolocation' in navigator)
|
||||
&& navigator.geolocation.watchPosition(Syndicate.Dataspace.wrap(function (pos) {
|
||||
Syndicate.Dataspace.send(locationRecord(id,
|
||||
email_element.value.trim(),
|
||||
+new Date(),
|
||||
pos.coords.latitude,
|
||||
pos.coords.longitude));
|
||||
if (!mapInitialized && map) {
|
||||
mapInitialized = true;
|
||||
map.setCenter({lat: pos.coords.latitude, lng: pos.coords.longitude});
|
||||
}
|
||||
}, function (err) {
|
||||
console.error(err);
|
||||
alert(err);
|
||||
}, {
|
||||
enableHighAccuracy: true,
|
||||
timeout: 15000
|
||||
}));
|
||||
|
||||
Syndicate.Actor.declareField(this, "currentLocation", null);
|
||||
var selectedMarker = null;
|
||||
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return Syndicate.Patch.assert(brokerConnection(this.wsurl), 0); }));
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return (this.currentLocation) ? Syndicate.Patch.assert(toBroker(this.wsurl, this.currentLocation), 0) : Syndicate.Patch.emptyPatch; }));
|
||||
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(Syndicate.UI.globalEvent('#my_email', 'change', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: Syndicate.UI.globalEvent('#my_email', 'change', _), metalevel: 0 }; }), (function() {
|
||||
var v = email_element.value.trim();
|
||||
if (this.currentLocation) this.currentLocation = this.currentLocation.set(1, v);
|
||||
localStorage.my_email = v;
|
||||
}));
|
||||
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(Syndicate.UI.globalEvent('#group', 'change', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: Syndicate.UI.globalEvent('#group', 'change', _), metalevel: 0 }; }), (function() {
|
||||
localStorage.group = group_element.value.trim();
|
||||
this.wsurl = wsurl_base + group_element.value.trim();
|
||||
}));
|
||||
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(Syndicate.UI.globalEvent('#findMarker', 'click', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: Syndicate.UI.globalEvent('#findMarker', 'click', (Syndicate._$("e"))), metalevel: 0 }; }), (function(e) {
|
||||
Syndicate.Dataspace.send(findMarker(document.getElementById('markerList').value));
|
||||
}));
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(Syndicate.UI.globalEvent('#markerList', 'change', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: Syndicate.UI.globalEvent('#markerList', 'change', (Syndicate._$("e"))), metalevel: 0 }; }), (function(e) {
|
||||
Syndicate.Dataspace.send(findMarker(document.getElementById('markerList').value));
|
||||
}));
|
||||
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub((locationRecord(_, _, _, _, _)), 0); }), (function() { var _ = Syndicate.__; return { assertion: ((Syndicate._$("loc",locationRecord(_, _, _, _, _)))), metalevel: 0 }; }), (function(loc) {
|
||||
this.currentLocation = loc;
|
||||
}));
|
||||
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "asserted", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(fromBroker(this.wsurl, locationRecord(_, _, _, _, _)), 0); }), (function() { var _ = Syndicate.__; return { assertion: fromBroker(this.wsurl, locationRecord((Syndicate._$("id")), (Syndicate._$("email")), _, _, _)), metalevel: 0 }; }), (function(id, email) {
|
||||
var _cachedAssertion1522142577531_0 = (function() { var _ = Syndicate.__; return fromBroker(this.wsurl, locationRecord(id, email, _, _, _)); }).call(this);
|
||||
{ Syndicate.Actor.Facet.build(function () { {
|
||||
var ui = new Syndicate.UI.Anchor();
|
||||
var marker = new google.maps.Marker({
|
||||
map: map,
|
||||
clickable: true,
|
||||
icon: 'https://www.gravatar.com/avatar/' + md5(email.trim().toLowerCase()) + '?s=32&d=retro'
|
||||
});
|
||||
var latestTimestamp = null;
|
||||
var latestPosition = null;
|
||||
function selectMarker() {
|
||||
selectedMarker = marker;
|
||||
updateInfoWindow();
|
||||
infoWindow.open(map, marker);
|
||||
}
|
||||
function updateInfoWindow() {
|
||||
if (selectedMarker === marker && latestPosition && latestTimestamp) {
|
||||
geocoder.geocode({'location': latestPosition}, function (results, status) {
|
||||
if (status === google.maps.GeocoderStatus.OK && results[0]) {
|
||||
infoWindow.setContent(Mustache.render(document.getElementById('info').innerHTML, {
|
||||
email: email,
|
||||
timestamp: latestTimestamp ? latestTimestamp.toString() : '',
|
||||
address: results[0].formatted_address
|
||||
}));
|
||||
}
|
||||
});
|
||||
}
|
||||
}
|
||||
Syndicate.Actor.Facet.current.addInitBlock((function() {
|
||||
marker.addListener('click', Syndicate.Dataspace.wrap(function () {
|
||||
selectMarker();
|
||||
}));
|
||||
}));
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return Syndicate.Patch.assert(ui.html('#markerList',
|
||||
Mustache.render(document.getElementById('markerList-option').innerHTML, {
|
||||
id: id,
|
||||
email: email
|
||||
})), 0); }));
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(findMarker(id), 0); }), (function() { var _ = Syndicate.__; return { assertion: findMarker(id), metalevel: 0 }; }), (function() {
|
||||
selectMarker();
|
||||
if (latestPosition) map.panTo(latestPosition);
|
||||
}));
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "asserted", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(fromBroker(this.wsurl, locationRecord(id, email, _, _, _)), 0); }), (function() { var _ = Syndicate.__; return { assertion: fromBroker(this.wsurl, locationRecord(id, email, (Syndicate._$("timestamp")), (Syndicate._$("lat")), (Syndicate._$("lng")))), metalevel: 0 }; }), (function(timestamp, lat, lng) {
|
||||
latestTimestamp = new Date(timestamp);
|
||||
latestPosition = {lat: lat, lng: lng};
|
||||
marker.setPosition(latestPosition);
|
||||
marker.setTitle(email + ' ' + latestTimestamp.toTimeString());
|
||||
updateInfoWindow();
|
||||
}));
|
||||
Syndicate.Actor.Facet.current.addDoneBlock((function() {
|
||||
marker.setMap(null);
|
||||
if (selectedMarker === marker) selectedMarker = null;
|
||||
}));
|
||||
}
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, true, "retracted", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(_cachedAssertion1522142577531_0, 0); }), (function() { var _ = Syndicate.__; return { assertion: _cachedAssertion1522142577531_0, metalevel: 0 }; }), (function() {})); }); }}));
|
||||
} }); });
|
||||
}).startStepping();
|
|
@ -0,0 +1,81 @@
|
|||
"use strict";
|
||||
var G = new Syndicate.Ground(function () {
|
||||
var shiftClicked = Syndicate.Struct.makeConstructor("shiftClicked", ["fragmentId"]);
|
||||
|
||||
Syndicate.UI.spawnUIDriver();
|
||||
|
||||
Syndicate.Actor.spawnActor(function() { Syndicate.Actor.Facet.build(function () { {
|
||||
var uiRoot = new Syndicate.UI.Anchor();
|
||||
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return Syndicate.Patch.assert(uiRoot.html('#place', '<svg id="svgroot" width="100%" height="100%"/>'), 0); }));
|
||||
|
||||
Syndicate.Actor.spawnActor(function() { Syndicate.Actor.Facet.build(function () { {
|
||||
var ui = new Syndicate.UI.Anchor();
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return Syndicate.Patch.assert(ui.html('#svgroot',
|
||||
'<rect id="underlay" x="0" y="0" width="100%" height="100%" fill="grey"/>',
|
||||
-1), 0); }));
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(ui.event('.', 'click', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: ui.event('.', 'click', (Syndicate._$("e"))), metalevel: 0 }; }), (function(e) {
|
||||
var svg = document.getElementById('svgroot');
|
||||
var pt = svg.createSVGPoint();
|
||||
pt.x = e.clientX;
|
||||
pt.y = e.clientY;
|
||||
pt = pt.matrixTransform(svg.getScreenCTM().inverse());
|
||||
spawnRectangle(pt.x, pt.y);
|
||||
}));
|
||||
} }); });
|
||||
|
||||
Syndicate.Actor.spawnActor(function() { Syndicate.Actor.Facet.build(function () { {
|
||||
Syndicate.Actor.declareField(this, "x", 50);
|
||||
Syndicate.Actor.declareField(this, "y", 50);
|
||||
var ui = new Syndicate.UI.Anchor();
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return Syndicate.Patch.assert(ui.html('#svgroot',
|
||||
'<circle fill="green" r=45 cx="'+this.x+'" cy="'+this.y+'"/>',
|
||||
0), 0); }));
|
||||
draggableMixin(this, ui);
|
||||
} }); });
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////
|
||||
|
||||
function spawnRectangle(x0, y0) {
|
||||
var length = 90;
|
||||
Syndicate.Actor.spawnActor(function() { Syndicate.Actor.Facet.build(function () { {
|
||||
Syndicate.Actor.declareField(this, "x", x0 - length / 2);
|
||||
Syndicate.Actor.declareField(this, "y", y0 - length / 2);
|
||||
var ui = new Syndicate.UI.Anchor();
|
||||
Syndicate.Actor.Facet.current.addAssertion((function() { var _ = Syndicate.__; return Syndicate.Patch.assert(ui.html('#svgroot',
|
||||
'<rect fill="yellow" stroke="black" stroke-width="3" width="90" height="90"'+
|
||||
' x="'+this.x+'" y="'+this.y+'"/>',
|
||||
0), 0); }));
|
||||
draggableMixin(this, ui);
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(ui.event('.', 'mousedown', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: ui.event('.', 'mousedown', (Syndicate._$("e"))), metalevel: 0 }; }), (function(e) {
|
||||
if (e.shiftKey) { Syndicate.Dataspace.send(shiftClicked(ui.fragmentId)); }
|
||||
}));
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, true, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(shiftClicked(ui.fragmentId), 0); }), (function() { var _ = Syndicate.__; return { assertion: shiftClicked(ui.fragmentId), metalevel: 0 }; }), (function() {}));
|
||||
} }); });
|
||||
}
|
||||
|
||||
function draggableMixin(obj, ui) {
|
||||
idle();
|
||||
|
||||
function idle() {
|
||||
(function () { Syndicate.Actor.Facet.build(function () { {
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, true, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(ui.event('.', 'mousedown', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: ui.event('.', 'mousedown', (Syndicate._$("e"))), metalevel: 0 }; }), (function(e) {
|
||||
dragging(e.clientX - obj.x, e.clientY - obj.y);
|
||||
}));
|
||||
} }); }).call(this);
|
||||
}
|
||||
|
||||
function dragging(dx, dy) {
|
||||
(function () { Syndicate.Actor.Facet.build(function () { {
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, false, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(uiRoot.event('.', 'mousemove', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: uiRoot.event('.', 'mousemove', (Syndicate._$("e"))), metalevel: 0 }; }), (function(e) {
|
||||
obj.x = e.clientX - dx;
|
||||
obj.y = e.clientY - dy;
|
||||
}));
|
||||
Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, true, "message", (function() { var _ = Syndicate.__; return Syndicate.Patch.sub(uiRoot.event('.', 'mouseup', _), 0); }), (function() { var _ = Syndicate.__; return { assertion: uiRoot.event('.', 'mouseup', _), metalevel: 0 }; }), (function() {
|
||||
idle();
|
||||
}));
|
||||
} }); }).call(this);
|
||||
}
|
||||
}
|
||||
} }); });
|
||||
}).startStepping();
|
|
@ -1 +0,0 @@
|
|||
compiled/
|
|
@ -1,29 +0,0 @@
|
|||
# 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
|
|
@ -1,24 +0,0 @@
|
|||
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.
|
|
@ -1,12 +0,0 @@
|
|||
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 $@
|
|
@ -1,196 +0,0 @@
|
|||
#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)
|
|
@ -1,52 +0,0 @@
|
|||
#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))
|
|
@ -1,21 +0,0 @@
|
|||
#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
|
|
@ -1,219 +0,0 @@
|
|||
#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;
|
||||
}
|
|
@ -1,21 +0,0 @@
|
|||
#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))]))
|
|
@ -1,80 +0,0 @@
|
|||
#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))
|
|
@ -1,125 +0,0 @@
|
|||
#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)
|
|
@ -1,26 +0,0 @@
|
|||
#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"))))
|
|
@ -1,268 +0,0 @@
|
|||
#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)
|
|
@ -1,91 +0,0 @@
|
|||
#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)))))))
|
|
@ -1,67 +0,0 @@
|
|||
#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);
|
||||
;; }
|
|
@ -1,36 +0,0 @@
|
|||
#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)))))
|
|
@ -1,797 +0,0 @@
|
|||
#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)
|
|
@ -1,142 +0,0 @@
|
|||
#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)
|
|
@ -1,7 +0,0 @@
|
|||
all:
|
||||
|
||||
run:
|
||||
raco make main.rkt && racket main.rkt
|
||||
|
||||
clean:
|
||||
find . -name compiled -type d | xargs rm -rf
|
|
@ -1,235 +0,0 @@
|
|||
#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)))))
|
|
@ -1,52 +0,0 @@
|
|||
#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))
|
|
@ -1,21 +0,0 @@
|
|||
#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
|
|
@ -1,26 +0,0 @@
|
|||
#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)))])))
|
|
@ -1,80 +0,0 @@
|
|||
#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))
|
|
@ -1,134 +0,0 @@
|
|||
#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 (?!))))
|