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
|
## 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
|
An implementation of a
|
||||||
[standard challenge problem](http://todomvc.com/) for web programming:
|
[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 (?!))))
|
|