Try bitsets instead of tsets

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.

Makefile

@@ -1,5 +1,5 @@
-PACKAGENAME=syndicate
-COLLECTS=syndicate syndicate-gl syndicate-ide
+PACKAGENAME=prospect
+COLLECTS=prospect
 
 all: setup
 

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/>.

doc/demand-matcher.dot

@@ -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"];
-
-}

doc/demand-matcher.md

@@ -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.

examples/ircd/.gitignore

@@ -1,2 +0,0 @@
-scratch/
-compiled/

examples/ircd/Makefile

@@ -1,7 +0,0 @@
-all:
-
-run:
-	raco make main.rkt && racket main.rkt
-
-clean:
-	rm -rf compiled

examples/ircd/TODO.md

@@ -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??

examples/ircd/channel.rkt

@@ -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))))

examples/ircd/config.rkt

@@ -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)))

examples/ircd/main.rkt

@@ -1,7 +0,0 @@
-#lang syndicate
-
-(require/activate syndicate/reload)
-
-(spawn-reloader "config.rkt")
-(spawn-reloader "session.rkt")
-(spawn-reloader "channel.rkt")

examples/ircd/message.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"))

examples/ircd/protocol.rkt

@@ -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]))

examples/ircd/session.rkt

@@ -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))))

examples/netstack/README.md

@@ -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

examples/netstack/TODO.md

@@ -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.

examples/netstack/incremental-highlevel/Makefile

@@ -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 $@

examples/netstack/incremental-highlevel/arp.rkt

@@ -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)

examples/netstack/incremental-highlevel/checksum.rkt

@@ -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))

examples/netstack/incremental-highlevel/configuration.rkt

@@ -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

examples/netstack/incremental-highlevel/cpingresp.c

@@ -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;
-}

examples/netstack/incremental-highlevel/demo-config.rkt

@@ -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))]))

examples/netstack/incremental-highlevel/dump-bytes.rkt

@@ -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))

examples/netstack/incremental-highlevel/ethernet.rkt

@@ -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)

examples/netstack/incremental-highlevel/fetchurl.rkt

@@ -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"))))

examples/netstack/incremental-highlevel/ip.rkt

@@ -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)

examples/netstack/incremental-highlevel/main.rkt

@@ -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)))))))

examples/netstack/incremental-highlevel/pingresp.rkt

@@ -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);
-;;     }

examples/netstack/incremental-highlevel/port-allocator.rkt

@@ -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)))))

examples/netstack/incremental-highlevel/tcp.rkt

@@ -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)

examples/netstack/incremental-highlevel/udp.rkt

@@ -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)

examples/netstack/monolithic-lowlevel/Makefile

@@ -1,7 +0,0 @@
-all:
-
-run:
-	raco make main.rkt && racket main.rkt
-
-clean:
-	find . -name compiled -type d | xargs rm -rf

examples/netstack/monolithic-lowlevel/arp.rkt

@@ -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)))))

examples/netstack/monolithic-lowlevel/checksum.rkt

@@ -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))

examples/netstack/monolithic-lowlevel/configuration.rkt

@@ -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

examples/netstack/monolithic-lowlevel/demo-config.rkt

@@ -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)))])))

examples/netstack/monolithic-lowlevel/dump-bytes.rkt

@@ -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))

examples/netstack/monolithic-lowlevel/ethernet.rkt

@@ -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 (?!))))

examples/netstack/monolithic-lowlevel/fetchurl.rkt

@@ -1,48 +0,0 @@
-#lang syndicate/monolithic
-
-(require syndicate/drivers/timer)
-(require "demo-config.rkt")
-(require "ethernet.rkt")
-(require "arp.rkt")
-(require "ip.rkt")
-(require "tcp.rkt")
-(require "udp.rkt")
-
-;;(log-events-and-actions? #t)
-
-(spawn-timer-driver)
-(spawn-ethernet-driver)
-(spawn-arp-driver)
-(spawn-ip-driver)
-(spawn-tcp-driver)
-(spawn-udp-driver)
-(spawn-demo-config)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(let ()
-  (define local-handle (tcp-handle 'httpclient))
-  (define remote-handle (tcp-address "129.10.115.92" 80))
-
-  (spawn (lambda (e seen-peer?)
-	   (match e
-	     [(scn g)
-	      (define peer-present? (trie-non-empty? g))
-              (if (and (not peer-present?) seen-peer?)
-                  (begin (printf "URL fetcher exiting.\n")
-                         (quit))
-                  (transition (or seen-peer? peer-present?)
-			      (message
-                               (tcp-channel
-                                local-handle
-                                remote-handle
-                                #"GET / HTTP/1.0\r\nHost: stockholm.ccs.neu.edu\r\n\r\n"))))]
-	     [(message (tcp-channel _ _ bs))
-	      (printf "----------------------------------------\n~a\n" bs)
-	      (printf "----------------------------------------\n")
-	      #f]
-	     [_ #f]))
-	 #f
-	 (scn/union (advertisement (tcp-channel local-handle remote-handle ?))
-                    (subscription (tcp-channel remote-handle local-handle ?))
-                    (subscription (advertise (tcp-channel remote-handle local-handle ?))))))

examples/netstack/monolithic-lowlevel/ip.rkt

@@ -1,328 +0,0 @@
-#lang racket/base
-
-(provide (struct-out ip-packet)
-	 ip-address->hostname
-	 ip-string->ip-address
-	 apply-netmask
-	 ip-address-in-subnet?
-	 gestalt->local-ip-addresses
-	 observe-local-ip-addresses-gestalt
-	 broadcast-ip-address
-	 spawn-ip-driver)
-
-(require racket/set)
-(require racket/match)
-(require (only-in racket/string string-split))
-(require syndicate/monolithic)
-(require syndicate/drivers/timer)
-(require syndicate/demand-matcher)
-(require syndicate/protocol/advertise)
-(require bitsyntax)
-
-(require "dump-bytes.rkt")
-(require "configuration.rkt")
-(require "checksum.rkt")
-(require "ethernet.rkt")
-(require "arp.rkt")
-(require "on-claim.rkt")
-
-(struct ip-packet (source-interface ;; string for an ethernet interface, or #f for local interfaces
-		   source
-		   destination
-		   protocol
-		   options
-		   body)
-	#:prefab) ;; TODO: more fields
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (ip-address->hostname bs)
-  (bit-string-case bs
-    ([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
-
-(define (ip-string->ip-address str)
-  (list->bytes (map string->number (string-split str "."))))
-
-(define (apply-netmask addr netmask)
-  (bit-string-case addr
-    ([ (n :: integer bytes 4) ]
-     (bit-string ((bitwise-and n (arithmetic-shift #x-100000000 (- netmask)))
-		  :: integer bytes 4)))))
-
-(define (ip-address-in-subnet? addr network netmask)
-  (equal? (apply-netmask network netmask)
-	  (apply-netmask addr netmask)))
-
-(define broadcast-ip-address (bytes 255 255 255 255))
-
-(define local-ip-address-projector (host-route (?!) ? ?))
-(define (gestalt->local-ip-addresses g) (trie-project/set/single g local-ip-address-projector))
-(define observe-local-ip-addresses-gestalt (subscription (host-route ? ? ?)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (spawn-ip-driver)
-  (list
-   (spawn-demand-matcher (host-route (?!) (?!) (?!))
-                         (route-up (host-route (?!) (?!) (?!)))
-			 spawn-host-route)
-   (spawn-demand-matcher (gateway-route (?!) (?!) (?!) (?!))
-                         (route-up (gateway-route (?!) (?!) (?!) (?!)))
-			 spawn-gateway-route)
-   (spawn-demand-matcher (net-route (?!) (?!) (?!))
-                         (route-up (net-route (?!) (?!) (?!)))
-			 spawn-net-route)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Local IP route
-
-(define (spawn-host-route my-address netmask interface-name)
-  (list
-   (let ((network-addr (apply-netmask my-address netmask)))
-     (spawn-normal-ip-route (host-route my-address netmask interface-name)
-			    network-addr
-			    netmask
-			    interface-name))
-   (actor (lambda (e s)
-	    (match e
-	      [(scn (? trie-empty?)) (quit)]
-	      [(message (ip-packet _ peer-address _ _ _ body))
-	       (bit-string-case body
-		 ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
-		  (case type
-		    [(8) ;; ECHO (0 is ECHO-REPLY)
-		     (log-info "Ping of ~a from ~a"
-			       (pretty-bytes my-address)
-			       (pretty-bytes peer-address))
-		     (define reply-data0 (bit-string 0
-						     code
-						     (0 :: integer bytes 2) ;; TODO
-						     (rest :: binary)))
-		     (transition s (message (ip-packet #f
-                                                       my-address
-                                                       peer-address
-                                                       PROTOCOL-ICMP
-                                                       #""
-                                                       (ip-checksum 2 reply-data0))))]
-		    [else
-		     (log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
-			       type
-			       code
-			       checksum
-			       (pretty-bytes my-address)
-			       (pretty-bytes peer-address)
-			       (dump-bytes->string rest))
-		     #f]))
-		 (else #f))]
-	      [_ #f]))
-	  (void)
-          (scn/union (advertisement (ip-packet ? my-address ? PROTOCOL-ICMP ? ?))
-                     (subscription (ip-packet ? ? my-address PROTOCOL-ICMP ? ?))
-                     (assertion (arp-assertion IPv4-ethertype my-address interface-name))
-                     (subscription (host-route my-address netmask interface-name))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Gateway IP route
-
-(struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent)
-
-(define (spawn-gateway-route network netmask gateway-addr interface-name)
-  (define the-route (gateway-route network netmask gateway-addr interface-name))
-
-  (define host-route-projector (host-route (?!) (?!) ?))
-  (define gateway-route-projector (gateway-route (?!) (?!) ? ?))
-  (define net-route-projector (net-route (?!) (?!) ?))
-  (define gateway-arp-projector (arp-query IPv4-ethertype
-                                           gateway-addr
-                                           (?! (ethernet-interface interface-name ?))
-                                           (?!)))
-
-  (define (covered-by-some-other-route? addr routes)
-    (for/or ([r (in-set routes)])
-      (match-define (list net msk) r)
-      (and (positive? msk)
-	   (ip-address-in-subnet? addr net msk))))
-
-  (actor (lambda (e s)
-	   (match e
-	     [(scn g)
-	      (define host-ips+netmasks (trie-project/set #:take 2 g host-route-projector))
-	      (define gw-nets+netmasks (trie-project/set #:take 2 g gateway-route-projector))
-	      (define net-nets+netmasks (trie-project/set #:take 2 g net-route-projector))
-	      (define gw-ip+hwaddr
-                (let ((vs (trie-project/set #:take 2 g gateway-arp-projector)))
-                  (and vs (not (set-empty? vs)) (set-first vs))))
-	      (when (and gw-ip+hwaddr (not (gateway-route-state-gateway-hwaddr s)))
-		(log-info "Discovered gateway ~a at ~a on interface ~a."
-			  (ip-address->hostname gateway-addr)
-			  (ethernet-interface-name (car gw-ip+hwaddr))
-			  (pretty-bytes (cadr gw-ip+hwaddr))))
-              (if (trie-empty? (project-assertions g (?! the-route)))
-                  (quit)
-                  (transition (gateway-route-state
-                               (set-union host-ips+netmasks
-                                          gw-nets+netmasks
-                                          net-nets+netmasks)
-                               (and gw-ip+hwaddr (car gw-ip+hwaddr))
-                               (and gw-ip+hwaddr (cadr gw-ip+hwaddr)))
-                              '()))]
-	     [(message (? ip-packet? p))
-	      (define gw-if (gateway-route-state-gateway-interface s))
-	      (when (not gw-if)
-		(log-warning "Gateway hwaddr for ~a not known, packet dropped."
-			     (ip-address->hostname gateway-addr)))
-	      (and gw-if
-		   (not (equal? (ip-packet-source-interface p) (ethernet-interface-name gw-if)))
-		   (not (covered-by-some-other-route? (ip-packet-destination p)
-						      (gateway-route-state-routes s)))
-		   (transition s
-			       (message (ethernet-packet gw-if
-                                                         #f
-                                                         (ethernet-interface-hwaddr gw-if)
-                                                         (gateway-route-state-gateway-hwaddr s)
-                                                         IPv4-ethertype
-                                                         (format-ip-packet p)))))]
-	     [_ #f]))
-	 (gateway-route-state (set) #f #f)
-         (scn/union (subscription the-route)
-                    (assertion (route-up the-route))
-                    (subscription (ip-packet ? ? ? ? ? ?))
-                    observe-local-ip-addresses-gestalt
-                    (subscription (net-route ? ? ?))
-                    (subscription (gateway-route ? ? ? ?))
-                    (subscription (projection->pattern gateway-arp-projector)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; General net route
-
-(define (spawn-net-route network-addr netmask link)
-  (spawn-normal-ip-route (net-route network-addr netmask link) network-addr netmask link))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Normal IP route
-
-(define (spawn-normal-ip-route the-route network netmask interface-name)
-  (actor (lambda (e s)
-	   (match e
-	     [(scn (? trie-empty?)) (quit)]
-	     [(message (ethernet-packet _ _ _ _ _ body))
-	      (define p (parse-ip-packet interface-name body))
-	      (and p (transition s (message p)))]
-	     [(message (? ip-packet? p))
-	      (define destination (ip-packet-destination p))
-	      (and (not (equal? (ip-packet-source-interface p) interface-name))
-		   (ip-address-in-subnet? destination network netmask)
-		   (transition
-		    s
-		    (lookup-arp destination
-				(ethernet-interface interface-name ?)
-                                trie-empty
-				(lambda (interface destination-hwaddr)
-				  (message (ethernet-packet interface
-                                                            #f
-                                                            (ethernet-interface-hwaddr interface)
-                                                            destination-hwaddr
-                                                            IPv4-ethertype
-                                                            (format-ip-packet p)))))))]
-	     [_ #f]))
-	 (void)
-         (scn/union (subscription the-route)
-                    (assertion (route-up the-route))
-                    (subscription (ethernet-packet-pattern interface-name #t IPv4-ethertype))
-                    (assertion (arp-interface interface-name))
-                    (subscription (ip-packet ? ? ? ? ? ?)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define IPv4-ethertype #x0800)
-
-(define IP-VERSION 4)
-(define IP-MINIMUM-HEADER-LENGTH 5)
-
-(define PROTOCOL-ICMP 1)
-
-(define default-ttl 64)
-
-(define (parse-ip-packet interface-name body)
-  ;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body))
-  (bit-string-case body
-    ([ (= IP-VERSION :: bits 4)
-       (header-length :: bits 4)
-       service-type
-       (total-length :: bits 16)
-       (id :: bits 16)
-       (flags :: bits 3)
-       (fragment-offset :: bits 13)
-       ttl
-       protocol
-       (header-checksum :: bits 16) ;; TODO: check checksum
-       (source-ip0 :: binary bits 32)
-       (destination-ip0 :: binary bits 32)
-       (rest :: binary) ]
-     (let* ((source-ip (bit-string->bytes source-ip0))
-	    (destination-ip (bit-string->bytes destination-ip0))
-	    (options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH)))
-	    (data-length (- total-length (* 4 header-length))))
-       (if (and (>= header-length 5)
-		(>= (bit-string-byte-count body) (* header-length 4)))
-	   (bit-string-case rest
-	     ([ (opts :: binary bytes options-length)
-		(data :: binary bytes data-length)
-		(:: binary) ] ;; Very short ethernet packets have a trailer of zeros
-	      (ip-packet interface-name
-			 (bit-string->bytes source-ip)
-			 (bit-string->bytes destination-ip)
-			 protocol
-			 (bit-string->bytes opts)
-			 (bit-string->bytes data))))
-	   #f)))
-    (else #f)))
-
-(define (format-ip-packet p)
-  (match-define (ip-packet _ src dst protocol options body) p)
-
-  (define header-length ;; TODO: ensure options is a multiple of 4 bytes
-    (+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4)))
-
-  (define header0 (bit-string (IP-VERSION :: bits 4)
-			      (header-length :: bits 4)
-			      0 ;; TODO: service type
-			      ((+ (* header-length 4) (bit-string-byte-count body))
-			       :: bits 16)
-			      (0 :: bits 16)  ;; TODO: identifier
-			      (0 :: bits 3)   ;; TODO: flags
-			      (0 :: bits 13)  ;; TODO: fragments
-			      default-ttl
-			      protocol
-			      (0 :: bits 16)
-			      (src :: binary bits 32)
-			      (dst :: binary bits 32)
-			      (options :: binary)))
-  (define full-packet (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary)))
-
-  full-packet)
-
-(define (lookup-arp ipaddr query-interface-pattern base-gestalt k)
-  (on-claim #:name (string->symbol (format "lookup-arp:~a" (ip-address->hostname ipaddr)))
-            (lambda (_g arp-results)
-              (if (not arp-results)
-                  (error 'ip "Someone has published a wildcard arp result")
-                  (and (not (set-empty? arp-results))
-                       (match (set-first arp-results)
-                         [(list interface hwaddr)
-                          (log-info "ARP lookup yielded ~a on ~a for ~a"
-                                    (pretty-bytes hwaddr)
-                                    (ethernet-interface-name interface)
-                                    (ip-address->hostname ipaddr))
-                          (when (> (set-count arp-results) 1)
-                            (log-warning "Ambiguous ARP result for ~a: ~v"
-                                         (ip-address->hostname ipaddr)
-                                         arp-results))
-                          (k interface hwaddr)]))))
-            base-gestalt
-            (arp-query IPv4-ethertype ipaddr (?! query-interface-pattern) (?!))
-            #:timeout-msec 5000
-            #:on-timeout (lambda ()
-                           (log-warning "ARP lookup of ~a failed, packet dropped"
-                                        (ip-address->hostname ipaddr))
-                           '())))

examples/netstack/monolithic-lowlevel/main.rkt

@@ -1,121 +0,0 @@
-#lang syndicate/monolithic
-
-(require syndicate/demand-matcher)
-(require syndicate/drivers/timer)
-(require syndicate/protocol/advertise)
-(require "demo-config.rkt")
-(require "ethernet.rkt")
-(require "arp.rkt")
-(require "ip.rkt")
-(require "tcp.rkt")
-(require "udp.rkt")
-
-;;(log-events-and-actions? #t)
-
-(spawn-timer-driver)
-(spawn-ethernet-driver)
-(spawn-arp-driver)
-(spawn-ip-driver)
-(spawn-tcp-driver)
-(spawn-udp-driver)
-(spawn-demo-config)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(let ()
-  (local-require racket/set racket/string)
-
-  (define (spawn-session them us)
-    (define user (gensym 'user))
-    (define remote-detector (inbound (?!)))
-    (define peer-detector (advertise `(,(?!) says ,?)))
-    (define (send-to-remote fmt . vs)
-      (message (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
-    (define (say who fmt . vs)
-      (unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
-    (list (send-to-remote "Welcome, ~a.\n" user)
-          (actor
-           (lambda (e peers)
-             (match e
-               [(message (inbound (tcp-channel _ _ bs)))
-                (transition peers (message `(,user says ,(string-trim (bytes->string/utf-8 bs)))))]
-               [(message `(,who says ,what))
-                (transition peers (say who "says: ~a" what))]
-               [(scn assertions)
-                (if (trie-empty? (trie-project assertions remote-detector))
-                    (quit (send-to-remote "Goodbye!\n"))
-                    (let ((new-peers (trie-project/set/single assertions peer-detector)))
-                      (define arrived (set-subtract new-peers peers))
-                      (define departed (set-subtract peers new-peers))
-                      (transition new-peers
-                                  (list (for/list [(who arrived)] (say who "arrived."))
-                                        (for/list [(who departed)] (say who "departed."))))))]
-               [#f #f]))
-           (set)
-           (scn/union
-            (subscription `(,? says ,?)) ;; read actual chat messages
-            (subscription (advertise `(,? says ,?))) ;; observe peer presence
-            (advertisement `(,user says ,?)) ;; advertise our presence
-            (subscription (inbound (tcp-channel them us ?))) ;; read from remote client
-            (subscription (inbound (advertise (tcp-channel them us ?)))) ;; monitor remote client
-            (advertisement (inbound (tcp-channel us them ?))) ;; we will write to remote client
-            ))))
-
-  (dataspace-actor
-   (spawn-demand-matcher (inbound (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?)))
-                         (inbound (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?)))
-                         spawn-session))
-  )
-
-(let ()
-  (actor (lambda (e s)
-	   (match e
-	     [(message (udp-packet src dst body))
-	      (log-info "Got packet from ~v: ~v" src body)
-	      (transition s (message
-                             (udp-packet dst
-                                         src
-                                         (string->bytes/utf-8 (format "You said: ~a" body)))))]
-	     [_ #f]))
-	 (void)
-	 (scn (subscription (udp-packet ? (udp-listener 6667) ?)))))
-
-(let ()
-  (define (spawn-session them us)
-    (list
-     (message 'bump)
-     (actor (lambda (e s)
-	      (match e
-		[(message `(counter ,counter))
-		 (define response
-		   (string->bytes/utf-8
-		    (format (string-append
-			     "HTTP/1.0 200 OK\r\n\r\n"
-			     "<h1>Hello world from syndicate-monolithic-netstack!</h1>\n"
-			     "<p>This is running on syndicate-monolithic's own\n"
-			     "<a href='https://github.com/tonyg/syndicate/'>\n"
-			     "TCP/IP stack</a>.</p>\n"
-			     "<p>There have been ~a requests prior to this one.</p>")
-			    counter)))
-		 (quit (message (outbound (tcp-channel us them response))))]
-		[_ #f]))
-	    (void)
-	    (scn/union (subscription `(counter ,?))
-                       (subscription (inbound (tcp-channel them us ?)))
-                       (subscription (inbound (advertise (tcp-channel them us ?))))
-                       (advertisement (inbound (tcp-channel us them ?)))))))
-
-  (dataspace-actor
-   (actor (lambda (e counter)
-	    (match e
-	      [(message 'bump)
-	       (transition (+ counter 1) (message `(counter ,counter)))]
-	      [_ #f]))
-	  0
-	  (scn (subscription 'bump)))
-   (spawn-demand-matcher
-    (inbound (advertise (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?)))
-    (inbound (observe (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 80)) ?)))
-    spawn-session))
-
-  )

examples/netstack/monolithic-lowlevel/on-claim.rkt

@@ -1,47 +0,0 @@
-#lang racket/base
-
-(provide on-claim)
-
-(require syndicate/monolithic)
-(require syndicate/drivers/timer)
-
-;; (Trie (Option (Setof (Listof Value))) ... -> (Option (Constreeof Action)))
-;;    Trie Projection ...
-;; -> Action
-;; Spawns a process that observes the given projections. Any time the
-;; environment's interests change in a relevant way, calls
-;; check-and-maybe-actor-fn with the aggregate interests and the
-;; projection results. If check-and-maybe-actor-fn returns #f,
-;; continues to wait; otherwise, takes the action(s) returned, and
-;; quits.
-(define (on-claim #:timeout-msec [timeout-msec #f]
-                  #:on-timeout [timeout-handler (lambda () '())]
-                  #:name [name #f]
-                  check-and-maybe-actor-fn
-                  base-interests
-                  . projections)
-  (define timer-id (gensym 'on-claim))
-  (define (on-claim-handler e state)
-    (match e
-      [(scn new-aggregate)
-       (define projection-results
-         (map (lambda (p) (trie-project/set #:take (projection-arity p) new-aggregate p))
-              projections))
-       (define maybe-actor (apply check-and-maybe-actor-fn
-                                  new-aggregate
-                                  projection-results))
-       (if maybe-actor
-           (quit maybe-actor)
-           #f)]
-      [(message (timer-expired (== timer-id) _))
-       (quit (timeout-handler))]
-      [_ #f]))
-  (list
-   (when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
-   (actor #:name name
-          on-claim-handler
-          (void)
-          (scn/union base-interests
-                     (assertion-set-union*
-                      (map (lambda (p) (subscription (projection->pattern p))) projections))
-                     (subscription (timer-expired timer-id ?))))))

examples/netstack/monolithic-lowlevel/port-allocator.rkt

@@ -1,38 +0,0 @@
-#lang racket/base
-;; UDP/TCP port allocator
-
-(provide spawn-port-allocator
-	 (struct-out port-allocation-request))
-
-(require racket/set)
-(require racket/match)
-(require syndicate/monolithic)
-(require "ip.rkt")
-
-(struct port-allocation-request (type k) #:prefab)
-
-(struct port-allocator-state (used-ports local-ips) #:transparent)
-
-(define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports)
-  (actor #:name (string->symbol (format "port-allocator:~a" allocator-type))
-         (lambda (e s)
-	   (match e
-	     [(scn g)
-	      (define local-ips (or (gestalt->local-ip-addresses g) (set)))
-	      (define new-used-ports (compute-used-ports g local-ips))
-	      (log-info "port-allocator ~v used ports: ~v" allocator-type new-used-ports)
-	      (transition (port-allocator-state new-used-ports local-ips) '())]
-	     [(message (port-allocation-request _ k))
-	      (define currently-used-ports (port-allocator-state-used-ports s))
-	      (let randomly-allocate-until-unused ()
-		(define p (+ 1024 (random 64512)))
-		(if (set-member? currently-used-ports p)
-		    (randomly-allocate-until-unused)
-		    (transition (struct-copy port-allocator-state s
-				  [used-ports (set-add currently-used-ports p)])
-				(k p (port-allocator-state-local-ips s)))))]
-	     [_ #f]))
-	 (port-allocator-state (set) (set))
-         (scn/union (subscription (port-allocation-request allocator-type ?))
-                    observe-local-ip-addresses-gestalt
-                    observer-gestalt)))

examples/netstack/monolithic-lowlevel/tcp.rkt

@@ -1,666 +0,0 @@
-#lang racket/base
-
-(provide (struct-out tcp-address)
-	 (struct-out tcp-handle)
-	 (struct-out tcp-listener)
-	 (struct-out tcp-channel)
-	 spawn-tcp-driver)
-
-(require racket/set)
-(require racket/match)
-(require syndicate/monolithic)
-(require syndicate/drivers/timer)
-(require syndicate/demand-matcher)
-(require syndicate/protocol/advertise)
-(require bitsyntax)
-
-(require "dump-bytes.rkt")
-(require "checksum.rkt")
-(require "ip.rkt")
-(require "port-allocator.rkt")
-
-;; tcp-address/tcp-address : "kernel" tcp connection state machines
-;; tcp-handle/tcp-address : "user" outbound connections
-;; tcp-listener/tcp-address : "user" inbound connections
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Protocol messages
-
-(struct tcp-address (host port) #:prefab)
-(struct tcp-handle (id) #:prefab)
-(struct tcp-listener (port) #:prefab)
-
-(struct tcp-channel (source destination subpacket) #:prefab)
-
-(struct tcp-packet (from-wire?
-		    source-ip
-		    source-port
-		    destination-ip
-		    destination-port
-		    sequence-number
-		    ack-number
-		    flags
-		    window-size
-		    options
-		    data)
-	#:prefab)
-
-;; (tcp-port-allocation Number (U TcpHandle TcpListener))
-(struct tcp-port-allocation (port handle) #:prefab)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; User-accessible driver startup
-
-(define (spawn-tcp-driver)
-  (list (spawn-demand-matcher #:name 'tcp-inbound-driver
-                              (advertise (observe (tcp-channel ? (?! (tcp-listener ?)) ?)))
-                              (advertise (advertise (tcp-channel ? (?! (tcp-listener ?)) ?)))
-			      (lambda (server-addr)
-				(match-define (tcp-listener port) server-addr)
-				;; TODO: have listener shut down once user-level listener does
-                                (list
-                                 (actor #:name (string->symbol
-                                                (format "tcp-listener-port-reservation:~a" port))
-                                        (lambda (e s) #f)
-                                        (void)
-                                        (scn (assertion (tcp-port-allocation port server-addr))))
-                                 (spawn-demand-matcher
-                                  #:name (string->symbol (format "tcp-listener:~a" port))
-                                  (advertise (tcp-channel (?! (tcp-address ? ?))
-                                                          (?! (tcp-address ? port))
-                                                          ?))
-                                  (observe (tcp-channel (?! (tcp-address ? ?))
-                                                        (?! (tcp-address ? port))
-                                                        ?))
-                                  (spawn-relay server-addr)))))
-	(spawn-demand-matcher #:name 'tcp-outbound-driver
-                              (advertise (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?))
-                              (observe (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?))
-                              allocate-port-and-spawn-socket)
-	(spawn-tcp-port-allocator)
-	(spawn-kernel-tcp-driver)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Port allocation
-
-(define (spawn-tcp-port-allocator)
-  (spawn-port-allocator 'tcp
-                        (subscription (tcp-port-allocation ? ?))
-			(lambda (g local-ips)
-                          (project-assertions g (tcp-port-allocation (?!) ?)))))
-
-(define (allocate-port-and-spawn-socket local-addr remote-addr)
-  (message (port-allocation-request
-            'tcp
-            (lambda (port local-ips)
-              ;; TODO: Choose a sensible IP address for the outbound
-              ;; connection. We don't have enough information to do this
-              ;; well at the moment, so just pick some available local IP
-              ;; address.
-              ;;
-              ;; Interesting note: In some sense, the right answer is
-              ;; "?". This would give us a form of mobility, where IP
-              ;; addresses only route to a given bucket-of-state and ONLY
-              ;; the port number selects a substate therein. That's not
-              ;; how TCP is defined however so we can't do that.
-              (define appropriate-ip (set-first local-ips))
-              (define appropriate-host (ip-address->hostname appropriate-ip))
-              (match-define (tcp-address remote-host remote-port) remote-addr)
-              (define remote-ip (ip-string->ip-address remote-host))
-              (list
-               ((spawn-relay local-addr) remote-addr (tcp-address appropriate-host port))
-               (spawn-state-vector remote-ip remote-port appropriate-ip port))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Relay between kernel-level and user-level
-
-(define relay-peer-wait-time-msec 5000)
-
-(define ((spawn-relay local-user-addr) remote-addr local-tcp-addr)
-  (define timer-name (list 'spawn-relay local-tcp-addr remote-addr))
-  (define local-peer-traffic (?! (observe (tcp-channel remote-addr local-user-addr ?))))
-  (define remote-peer-traffic (?! (advertise (tcp-channel remote-addr local-tcp-addr ?))))
-  (list
-   (message (set-timer timer-name relay-peer-wait-time-msec 'relative))
-   (actor #:name (string->symbol (format "tcp-relay:~v:~v:~v"
-                                         local-user-addr
-                                         remote-addr
-                                         local-tcp-addr))
-          (lambda (e state)
-	    (match e
-	      [(scn g)
-	       (define local-peer-absent? (trie-empty? (trie-project g local-peer-traffic)))
-	       (define remote-peer-absent? (trie-empty? (trie-project g remote-peer-traffic)))
-	       (define new-state (+ (if local-peer-absent? 0 1) (if remote-peer-absent? 0 1)))
-               (if (< new-state state)
-                   (quit)
-                   (transition new-state '()))]
-	      [(message (tcp-channel (== local-user-addr) (== remote-addr) bs))
-	       (transition state (message (tcp-channel local-tcp-addr remote-addr bs)))]
-	      [(message (tcp-channel (== remote-addr) (== local-tcp-addr) bs))
-	       (transition state (message (tcp-channel remote-addr local-user-addr bs)))]
-	      [(message (timer-expired _ _))
-	       #:when (< state 2) ;; we only care if we're not fully connected
-	       (error 'spawn-relay "TCP relay process timed out waiting for peer")]
-	      [_ #f]))
-	  0
-	  (scn/union (subscription (projection->pattern local-peer-traffic))
-                     (subscription (projection->pattern remote-peer-traffic))
-                     (assertion (tcp-port-allocation (tcp-address-port local-tcp-addr)
-                                                     local-user-addr))
-                     (subscription (tcp-channel remote-addr local-tcp-addr ?))
-                     (subscription (tcp-channel local-user-addr remote-addr ?))
-                     (advertisement (tcp-channel remote-addr local-user-addr ?))
-                     (advertisement (tcp-channel local-tcp-addr remote-addr ?))
-                     (subscription (timer-expired timer-name ?))))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Codec & kernel-level driver
-
-(define PROTOCOL-TCP 6)
-
-(struct codec-state (local-ips active-state-vectors) #:transparent)
-
-(define (spawn-kernel-tcp-driver)
-
-  (define (state-vector-active? statevec s)
-    (set-member? (codec-state-active-state-vectors s) statevec))
-
-  (define (analyze-incoming-packet src-ip dst-ip body s)
-    (bit-string-case body
-      ([ (src-port :: integer bytes 2)
-	 (dst-port :: integer bytes 2)
-	 (sequence-number :: integer bytes 4)
-	 (ack-number :: integer bytes 4)
-	 (data-offset :: integer bits 4)
-	 (reserved :: integer bits 3)
-	 (ns :: integer bits 1)
-	 (cwr :: integer bits 1)
-	 (ece :: integer bits 1)
-	 (urg :: integer bits 1)
-	 (ack :: integer bits 1)
-	 (psh :: integer bits 1)
-	 (rst :: integer bits 1)
-	 (syn :: integer bits 1)
-	 (fin :: integer bits 1)
-	 (window-size :: integer bytes 2)
-	 (checksum :: integer bytes 2) ;; TODO: check checksum
-	 (urgent-pointer :: integer bytes 2)
-	 (rest :: binary) ]
-       (let* ((flags (set))
-	      (statevec (list src-ip src-port dst-ip dst-port))
-	      (old-active-state-vectors (codec-state-active-state-vectors s))
-	      (spawn-needed? (and (not (state-vector-active? statevec s))
-				  (zero? rst)))) ;; don't bother spawning if it's a rst
-	 (define-syntax-rule (set-flags! v ...)
-	   (begin (unless (zero? v) (set! flags (set-add flags 'v))) ...))
-	 (set-flags! ns cwr ece urg ack psh rst syn fin)
-	 (log-info "TCP ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a)"
-		   (ip-address->hostname src-ip)
-		   src-port
-		   (ip-address->hostname dst-ip)
-		   dst-port
-		   sequence-number
-		   ack-number
-		   flags
-		   window-size)
-	 (when spawn-needed? (log-info "  - spawn needed!"))
-	 (bit-string-case rest
-	   ([ (opts :: binary bytes (- (* data-offset 4) 20))
-	      (data :: binary) ]
-	    (let ((packet (tcp-packet #t
-				      src-ip
-				      src-port
-				      dst-ip
-				      dst-port
-				      sequence-number
-				      ack-number
-				      flags
-				      window-size
-				      (bit-string->bytes opts)
-				      (bit-string->bytes data))))
-	      (transition (if spawn-needed?
-			      (struct-copy codec-state s
-				[active-state-vectors
-				 (set-add old-active-state-vectors statevec)])
-			      s)
-			  (list
-			   (when spawn-needed? (spawn-state-vector src-ip src-port
-								   dst-ip dst-port))
-			   ;; TODO: get packet to the new state-vector process somehow
-			   (message packet)))))
-	   (else #f))))
-      (else #f)))
-
-  (define statevec-projection (observe (tcp-packet ? (?!) (?!) (?!) (?!) ? ? ? ? ? ?)))
-
-  (define (analyze-gestalt g s)
-    (define local-ips (gestalt->local-ip-addresses g))
-    (define statevecs (trie-project/set #:take 4 g statevec-projection))
-    (log-info "gestalt yielded statevecs ~v and local-ips ~v" statevecs local-ips)
-    (transition (struct-copy codec-state s
-		  [local-ips local-ips]
-		  [active-state-vectors statevecs]) '()))
-
-  (define (deliver-outbound-packet p s)
-    (match-define (tcp-packet #f
-			      src-ip
-			      src-port
-			      dst-ip
-			      dst-port
-			      sequence-number
-			      ack-number
-			      flags
-			      window-size
-			      options
-			      data)
-      p)
-    (log-info "TCP ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a)"
-	      (ip-address->hostname src-ip)
-	      src-port
-	      (ip-address->hostname dst-ip)
-	      dst-port
-	      sequence-number
-	      ack-number
-	      flags
-	      window-size)
-    (define (flag-bit sym) (if (set-member? flags sym) 1 0))
-    (define payload (bit-string (src-port :: integer bytes 2)
-				(dst-port :: integer bytes 2)
-				(sequence-number :: integer bytes 4)
-				(ack-number :: integer bytes 4)
-				((+ 5 (quotient (bit-string-byte-count options) 4))
-				 :: integer bits 4) ;; TODO: enforce 4-byte alignment
-				(0 :: integer bits 3)
-				((flag-bit 'ns) :: integer bits 1)
-				((flag-bit 'cwr) :: integer bits 1)
-				((flag-bit 'ece) :: integer bits 1)
-				((flag-bit 'urg) :: integer bits 1)
-				((flag-bit 'ack) :: integer bits 1)
-				((flag-bit 'psh) :: integer bits 1)
-				((flag-bit 'rst) :: integer bits 1)
-				((flag-bit 'syn) :: integer bits 1)
-				((flag-bit 'fin) :: integer bits 1)
-				(window-size :: integer bytes 2)
-				(0 :: integer bytes 2) ;; checksum location
-				(0 :: integer bytes 2) ;; TODO: urgent pointer
-				(data :: binary)))
-    (define pseudo-header (bit-string (src-ip :: binary bytes 4)
-				      (dst-ip :: binary bytes 4)
-				      0
-				      PROTOCOL-TCP
-				      ((bit-string-byte-count payload) :: integer bytes 2)))
-    (transition s (message (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
-                                      (ip-checksum 16 payload #:pseudo-header pseudo-header)))))
-
-  (actor #:name 'kernel-tcp-driver
-         (lambda (e s)
-	   (match e
-	     [(scn g)
-	      (analyze-gestalt g s)]
-	     [(message (ip-packet source-if src dst _ _ body))
-	      #:when (and source-if ;; source-if == #f iff packet originates locally
-			  (set-member? (codec-state-local-ips s) dst))
-	      (analyze-incoming-packet src dst body s)]
-	     [(message (? tcp-packet? p))
-	      #:when (not (tcp-packet-from-wire? p))
-	      (deliver-outbound-packet p s)]
-	     [_ #f]))
-	 (codec-state (set) (set))
-	 (scn/union (subscription (ip-packet ? ? ? PROTOCOL-TCP ? ?))
-                    (subscription (tcp-packet #f ? ? ? ? ? ? ? ? ? ?))
-                    (subscription (observe (tcp-packet #t ? ? ? ? ? ? ? ? ? ?)))
-                    observe-local-ip-addresses-gestalt)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Per-connection state vector process
-
-(struct buffer (data ;; bit-string
-		seqn ;; names leftmost byte in data
-		window ;; counts bytes from leftmost byte in data
-		finished?) ;; boolean: true after FIN
-	#:transparent)
-
-(struct conn-state (outbound ;; buffer
-		    inbound ;; buffer
-		    syn-acked? ;; boolean
-		    latest-peer-activity-time ;; from current-inexact-milliseconds
-                    ;; ^ the most recent time we heard from our peer
-                    user-timeout-base-time ;; from current-inexact-milliseconds
-                    ;; ^ when the index of the first outbound unacknowledged byte changed
-		    local-peer-seen? ;; boolean
-		    listener-listening?) ;; boolean
-	#:transparent)
-
-(define transmit-check-interval-msec 2000)
-(define inbound-buffer-limit 65535)
-(define maximum-segment-size 536) ;; bytes
-(define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout
-(define user-timeout-msec (* 5 60 1000)) ;; per RFC 793, this should be per-connection, but I
-        ;; cheat; RFC 793 says "the present global default is five minutes", which is
-        ;; reasonable to be getting on with
-
-(define (spawn-state-vector src-ip src-port dst-ip dst-port)
-  (define src (tcp-address (ip-address->hostname src-ip) src-port))
-  (define dst (tcp-address (ip-address->hostname dst-ip) dst-port))
-  (define (timer-name kind) (list 'tcp-timer kind src dst))
-
-  (define (next-expected-seqn s)
-    (define b (conn-state-inbound s))
-    (define v (buffer-seqn b))
-    (and v (seq+ v (bit-string-byte-count (buffer-data b)))))
-
-  (define (buffer-push b data)
-    (struct-copy buffer b [data (bit-string-append (buffer-data b) data)]))
-
-  ;; ConnState -> ConnState
-  (define (set-inbound-seqn seqn s)
-    (struct-copy conn-state s
-      [inbound (struct-copy buffer (conn-state-inbound s) [seqn seqn])]))
-
-  ;; Bitstring ConnState -> Transition
-  (define (incorporate-segment data s)
-    ;; (log-info "GOT INBOUND STUFF TO DELIVER ~v" data)
-    (transition
-     (if (buffer-finished? (conn-state-inbound s))
-	 s
-	 (struct-copy conn-state s [inbound (buffer-push (conn-state-inbound s) data)]))
-     '()))
-
-  (define (seq+ a b) (bitwise-and #xffffffff (+ a b)))
-
-  ;; Always positive
-  (define (seq- larger smaller)
-    (if (< larger smaller) ;; wraparound has occurred
-	(+ (- larger smaller) #x100000000)
-	(- larger smaller)))
-
-  (define (seq> a b)
-    (< (seq- a b) #x80000000))
-
-  (define local-peer-detector (?! (observe (tcp-channel src dst ?))))
-  (define listener-detector (?! (observe (advertise (tcp-channel ? (tcp-listener dst-port) ?)))))
-
-  ;; ConnState -> Gestalt
-  (define (compute-gestalt s)
-    (define worldward-facing-gestalt
-      (subscription (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?)))
-    (define appward-facing-gestalt
-      (assertion-set-union
-       (subscription (projection->pattern local-peer-detector))
-       (subscription (projection->pattern listener-detector))
-       (subscription (tcp-channel dst src ?))
-       (if (and (conn-state-syn-acked? s)
-		(not (buffer-finished? (conn-state-inbound s))))
-	   (advertisement (tcp-channel src dst ?))
-	   trie-empty)))
-    (assertion-set-union (subscription (timer-expired (timer-name ?) ?))
-                         worldward-facing-gestalt
-                         appward-facing-gestalt))
-
-  ;; ConnState -> Transition
-  (define (deliver-inbound-locally s)
-    (define b (conn-state-inbound s))
-    (if (bit-string-empty? (buffer-data b))
-	(transition s '())
-	(let ((chunk (bit-string->bytes (buffer-data b))))
-	  (transition (struct-copy conn-state s
-			[inbound (struct-copy buffer b
-				   [data #""]
-				   [seqn (seq+ (buffer-seqn b) (bytes-length chunk))])])
-		      (message (tcp-channel src dst chunk))))))
-
-  ;; (Setof Symbol) -> ConnState -> Transition
-  (define ((check-fin flags) s)
-    (define b (conn-state-inbound s))
-    (unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
-      (error 'check-fin "Nonempty inbound buffer"))
-    (if (set-member? flags 'fin)
-	(let ((new-s (struct-copy conn-state s
-		       [inbound (struct-copy buffer b
-				  [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
-				  [finished? #t])])))
-	  (log-info "Closing inbound stream.")
-	  (transition new-s (scn (compute-gestalt new-s))))
-	(transition s '())))
-
-  ;; Boolean SeqNum -> ConnState -> Transition
-  (define ((discard-acknowledged-outbound ack? ackn) s)
-    (if (not ack?)
-	(transition s '())
-	(let* ((b (conn-state-outbound s))
-               (base (buffer-seqn b))
-	       (limit (seq+ (buffer-seqn b) (bit-string-byte-count (buffer-data b))))
-	       (ackn (if (seq> ackn limit) limit ackn))
-               (ackn (if (seq> base ackn) base ackn))
-	       (dist (seq- ackn base)))
-	  (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
-	  (define new-s (struct-copy conn-state s
-                          [user-timeout-base-time (current-inexact-milliseconds)]
-			  [outbound (struct-copy buffer b [data remaining-data] [seqn ackn])]
-			  [syn-acked? (or (conn-state-syn-acked? s)
-					  (positive? dist))]))
-	  (transition new-s
-		      (when (and (not (conn-state-syn-acked? s)) (positive? dist))
-			(scn (compute-gestalt new-s)))))))
-
-  ;; Nat -> ConnState -> Transition
-  (define ((update-outbound-window peer-window) s)
-    (transition (struct-copy conn-state s
-		  [outbound (struct-copy buffer (conn-state-outbound s)
-			      [window peer-window])])
-		'()))
-
-  ;; ConnState -> Boolean
-  (define (all-output-acknowledged? s)
-    (bit-string-empty? (buffer-data (conn-state-outbound s))))
-
-  ;; (Option SeqNum) -> ConnState -> Transition
-  (define ((send-outbound old-ackn) s)
-    (define b (conn-state-outbound s))
-    (define pending-byte-count (max 0 (- (bit-string-byte-count (buffer-data b))
-					 (if (buffer-finished? b) 1 0))))
-
-    (define segment-size (min maximum-segment-size
-			      (if (conn-state-syn-acked? s) (buffer-window b) 1)
-			      ;; ^ can only send SYN until SYN is acked
-			      pending-byte-count))
-    (define segment-offset (if (conn-state-syn-acked? s) 0 1))
-    (define chunk0 (bit-string-take (buffer-data b) (* segment-size 8))) ;; bit offset!
-    (define chunk (bit-string-drop chunk0 (* segment-offset 8))) ;; bit offset!
-    (define ackn (next-expected-seqn s))
-    (define flags (set))
-    (when ackn
-      (set! flags (set-add flags 'ack)))
-    (when (not (conn-state-syn-acked? s))
-      (set! flags (set-add flags 'syn)))
-    (when (and (buffer-finished? b)
-	       (conn-state-syn-acked? s)
-	       (= segment-size pending-byte-count)
-	       (not (all-output-acknowledged? s))) ;; TODO: reexamine. This looks fishy
-      (set! flags (set-add flags 'fin)))
-    (define window (min 65535 ;; limit of field width
-			(max 0 ;; can't be negative
-			     (- (buffer-window (conn-state-inbound s))
-				(bit-string-byte-count
-				 (buffer-data (conn-state-inbound s)))))))
-    (transition s
-		(unless (and (equal? ackn old-ackn)
-			     (conn-state-syn-acked? s)
-			     (not (set-member? flags 'fin))
-			     (zero? (bit-string-byte-count chunk)))
-		  (local-require racket/pretty)
-		  (pretty-write `(send-outbound (old-ackn ,old-ackn)
-						(s ,s)
-						(flags ,flags)))
-		  (flush-output)
-		  (message (tcp-packet #f dst-ip dst-port src-ip src-port
-                                       (buffer-seqn b)
-                                       (or ackn 0)
-                                       flags
-                                       window
-                                       #""
-                                       chunk)))))
-
-  ;; ConnState -> Transition
-  (define (bump-peer-activity-time s)
-    (transition (struct-copy conn-state s
-		  [latest-peer-activity-time (current-inexact-milliseconds)])
-		'()))
-
-  ;; ConnState Number -> Boolean
-  (define (heard-from-peer-within-msec? s msec)
-    (<= (- (current-inexact-milliseconds) (conn-state-latest-peer-activity-time s)) msec))
-
-  ;; ConnState -> Boolean
-  (define (user-timeout-expired? s)
-    (and (not (all-output-acknowledged? s))
-         (> (- (current-inexact-milliseconds) (conn-state-user-timeout-base-time s))
-            user-timeout-msec)))
-
-  ;; ConnState -> Transition
-  (define (quit-when-done s)
-    (cond
-      [(and (buffer-finished? (conn-state-outbound s))
-            (buffer-finished? (conn-state-inbound s))
-            (all-output-acknowledged? s)
-            (not (heard-from-peer-within-msec? s (* 2 1000 maximum-segment-lifetime-sec))))
-       ;; Everything is cleanly shut down, and we just need to wait a while for unexpected
-       ;; packets before we release the state vector.
-       (quit)]
-      [(user-timeout-expired? s)
-       ;; We've been plaintively retransmitting for user-timeout-msec without hearing anything
-       ;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but
-       ;; it will do for now? TODO
-       (log-info "TCP_USER_TIMEOUT fired.")
-       (quit)]
-      [else #f]))
-
-  ;; Action
-  (define send-set-transmit-check-timer
-    (message (set-timer (timer-name 'transmit-check)
-                        transmit-check-interval-msec
-                        'relative)))
-
-  ;; SeqNum SeqNum ConnState -> Transition
-  (define (reset seqn ackn s)
-    (log-warning "Sending RST from ~a:~a to ~a:~a"
-		 (ip-address->hostname dst-ip)
-		 dst-port
-		 (ip-address->hostname src-ip)
-		 src-port)
-    (quit (message (tcp-packet #f dst-ip dst-port src-ip src-port
-                               seqn
-                               ackn
-                               (set 'ack 'rst)
-                               0
-                               #""
-                               #""))))
-
-  ;; ConnState -> Transition
-  (define (close-outbound-stream s)
-    (define b (conn-state-outbound s))
-    (transition
-     (if (buffer-finished? b)
-         s
-         (struct-copy conn-state s
-                      [outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte
-                                             [finished? #t])]))
-     '()))
-
-  (define (state-vector-behavior e s)
-    (define old-ackn (buffer-seqn (conn-state-inbound s)))
-    (match e
-      [(scn g)
-       (log-info "State vector routing-update:\n~a" (trie->pretty-string g))
-       (define local-peer-present? (trie-non-empty? (trie-project g local-peer-detector)))
-       (define listening? (trie-non-empty? (trie-project g listener-detector)))
-       (define new-s (struct-copy conn-state s [listener-listening? listening?]))
-       (cond
-	[(and local-peer-present? (not (conn-state-local-peer-seen? s)))
-	 (transition (struct-copy conn-state new-s [local-peer-seen? #t]) '())]
-	[(and (not local-peer-present?) (conn-state-local-peer-seen? s))
-	 (log-info "Closing outbound stream.")
-	 (sequence-transitions (close-outbound-stream new-s)
-			       (send-outbound old-ackn)
-			       quit-when-done)]
-	[else (transition new-s '())])]
-      [(message (tcp-packet #t _ _ _ _ seqn ackn flags window options data))
-       (define expected (next-expected-seqn s))
-       (define is-syn? (set-member? flags 'syn))
-       (define is-fin? (set-member? flags 'fin))
-       (cond
-	[(set-member? flags 'rst) (quit)]
-	[(and (not expected)	 ;; no syn yet
-	      (or (not is-syn?)	 ;; and this isn't it
-		  (and (not (conn-state-listener-listening? s)) ;; or it is, but no listener...
-		       (not (conn-state-local-peer-seen? s))))) ;; ...and no outbound client
-	 (reset ackn ;; this is *our* seqn
-		(seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0)))
-		;; ^^ this is what we should acknowledge...
-		s)]
-	[else
-	 (sequence-transitions (cond
-				[(not expected) ;; haven't seen syn yet, but we know this is it
-				 (incorporate-segment data (set-inbound-seqn (seq+ seqn 1) s))]
-				[(= expected seqn)
-				 (incorporate-segment data s)]
-				[else
-				 (transition s '())])
-			       deliver-inbound-locally
-			       (check-fin flags)
-			       (discard-acknowledged-outbound (set-member? flags 'ack) ackn)
-			       (update-outbound-window window)
-			       (send-outbound old-ackn)
-			       bump-peer-activity-time
-			       quit-when-done)])]
-      [(message (tcp-channel _ _ bs))
-       ;; (log-info "GOT MORE STUFF TO DELIVER ~v" bs)
-       (sequence-transitions (transition (struct-copy conn-state s
-                                           [user-timeout-base-time
-                                            ;; Only move user-timeout-base-time if there wasn't
-                                            ;; already some outstanding output.
-                                            (if (all-output-acknowledged? s)
-                                                (current-inexact-milliseconds)
-                                                (conn-state-user-timeout-base-time s))]
-					   [outbound (buffer-push (conn-state-outbound s) bs)])
-					 '())
-			     (send-outbound old-ackn)
-			     quit-when-done)]
-      [(message (timer-expired (== (timer-name 'transmit-check)) _))
-       ;; TODO: I am abusing this timer for multiple tasks. Notably, this is a (crude) means of
-       ;; retransmitting outbound data as well as a means of checking for an expired
-       ;; TCP_USER_TIMEOUT. A better design would have separate timers and a more fine-grained
-       ;; approach.
-       (sequence-transitions (transition s send-set-transmit-check-timer)
-			     (send-outbound old-ackn)
-			     quit-when-done)]
-      [_ #f]))
-
-  ;; (local-require racket/trace)
-  ;; (trace state-vector-behavior)
-
-  (define initial-outbound-seqn
-    ;; Yuck
-    (inexact->exact (truncate (* #x100000000 (random)))))
-
-  ;; TODO accept input from user process
-  (list
-   send-set-transmit-check-timer
-   (let ((state0 (conn-state (buffer #"!" initial-outbound-seqn 0 #f) ;; dummy data at SYN position
-			     (buffer #"" #f inbound-buffer-limit #f)
-			     #f
-			     (current-inexact-milliseconds)
-                             (current-inexact-milliseconds)
-			     #f
-			     #f)))
-     (actor #:name
-            (string->symbol (format "tcp-state-vector:~a:~a:~a:~a"
-                                    (ip-address->hostname src-ip)
-                                    src-port
-                                    (ip-address->hostname dst-ip)
-                                    dst-port))
-            state-vector-behavior
-	    state0
-	    (scn (compute-gestalt state0))))))

examples/netstack/monolithic-lowlevel/udp.rkt

@@ -1,176 +0,0 @@
-#lang racket/base
-
-(provide (struct-out udp-remote-address)
-	 (struct-out udp-handle)
-	 (struct-out udp-listener)
-	 udp-address?
-	 udp-local-address?
-	 (struct-out udp-packet)
-	 spawn-udp-driver)
-
-(require racket/set)
-(require racket/match)
-(require syndicate/monolithic)
-(require syndicate/demand-matcher)
-(require syndicate/protocol/advertise)
-(require bitsyntax)
-
-(require "dump-bytes.rkt")
-(require "checksum.rkt")
-(require "ip.rkt")
-(require "port-allocator.rkt")
-
-;; udp-address/udp-address : "kernel" udp connection state machines
-;; udp-handle/udp-address : "user" outbound connections
-;; udp-listener/udp-address : "user" inbound connections
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Protocol messages
-
-(struct udp-remote-address (host port) #:prefab)
-(struct udp-handle (id) #:prefab)
-(struct udp-listener (port) #:prefab)
-
-(define (udp-address? x)
-  (or (udp-remote-address? x)
-      (udp-local-address? x)))
-
-(define (udp-local-address? x)
-  (or (udp-handle? x)
-      (udp-listener? x)))
-
-;; USER-level protocol
-(struct udp-packet (source destination body) #:prefab)
-
-;; KERNEL-level protocol
-(struct udp-datagram (source-ip source-port destination-ip destination-port body) #:prefab)
-(struct udp-port-allocation (port handle) #:prefab) ;; (udp-port-allocation Number UdpLocalAddress)
-
-(define any-remote (udp-remote-address ? ?))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; User-accessible driver startup
-
-(define (spawn-udp-driver)
-  (list
-   (spawn-demand-matcher (observe (udp-packet ? (?! (udp-listener ?)) ?))
-                         (advertise (udp-packet ? (?! (udp-listener ?)) ?))
-			 (lambda (handle) (spawn-udp-relay (udp-listener-port handle) handle)))
-   (spawn-demand-matcher (observe (udp-packet ? (?! (udp-handle ?)) ?))
-                         (advertise (udp-packet ? (?! (udp-handle ?)) ?))
-			 (lambda (handle)
-			   (message (port-allocation-request
-                                     'udp
-                                     (lambda (port local-ips) (spawn-udp-relay port handle))))))
-   (spawn-udp-port-allocator)
-   (spawn-kernel-udp-driver)))
-
-(define (spawn-udp-port-allocator)
-  (define udp-projector (udp-port-allocation (?!) ?))
-  (spawn-port-allocator 'udp
-                        (subscription (projection->pattern udp-projector))
-			(lambda (g local-ips)
-                          (project-assertions g udp-projector))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Relaying
-
-(define (spawn-udp-relay local-port local-user-addr)
-  (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr)
-
-  (define local-peer-detector (?! (observe (udp-packet any-remote local-user-addr ?))))
-
-  (define (compute-gestalt local-ips)
-    (for/fold [(g (assertion-set-union
-                   (subscription (projection->pattern local-peer-detector))
-                   (advertisement (udp-packet any-remote local-user-addr ?))
-                   observe-local-ip-addresses-gestalt
-                   (subscription (udp-packet local-user-addr any-remote ?))
-                   (assertion (udp-port-allocation local-port local-user-addr))))]
-              [(ip (in-set local-ips))]
-      (assertion-set-union g
-                           (subscription (udp-datagram ? ? ip local-port ?))
-                           (advertisement (udp-datagram ip local-port ? ? ?)))))
-
-  (actor (lambda (e local-ips)
-	   (match e
-	     [(scn g)
-	      (define new-local-ips (gestalt->local-ip-addresses g))
-              (if (trie-empty? (trie-project g local-peer-detector))
-                  (quit)
-                  (transition new-local-ips (scn (compute-gestalt new-local-ips))))]
-	     [(message (udp-packet (== local-user-addr) remote-addr bs))
-	      ;; Choose arbitrary local IP address for outbound packet!
-	      ;; TODO: what can be done? Must I examine the routing table?
-	      (match-define (udp-remote-address remote-host remote-port) remote-addr)
-	      (define remote-ip (ip-string->ip-address remote-host))
-	      (transition local-ips (message (udp-datagram (set-first local-ips)
-                                                           local-port
-                                                           remote-ip
-                                                           remote-port
-                                                           bs)))]
-	     [(message (udp-datagram si sp _ _ bs))
-	      (transition local-ips
-                          (message (udp-packet (udp-remote-address (ip-address->hostname si) sp)
-                                               local-user-addr
-                                               bs)))]
-	     [_ #f]))
-	 (set)
-	 (scn (compute-gestalt (set)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Codec & kernel-level driver
-
-(define PROTOCOL-UDP 17)
-
-(define (spawn-kernel-udp-driver)
-  (actor (lambda (e local-ips)
-	   (match e
-	     [(scn g)
-	      (transition (gestalt->local-ip-addresses g) '())]
-	     [(message (ip-packet source-if src-ip dst-ip _ _ body))
-	      #:when (and source-if (set-member? local-ips dst-ip))
-	      (bit-string-case body
-		([ (src-port :: integer bytes 2)
-		   (dst-port :: integer bytes 2)
-		   (length :: integer bytes 2)
-		   (checksum :: integer bytes 2) ;; TODO: check checksum
-		   (data :: binary) ]
-		 (bit-string-case data
-		   ([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes
-		      (:: binary) ]
-		    (transition local-ips (message (udp-datagram src-ip
-                                                                 src-port
-                                                                 dst-ip
-                                                                 dst-port
-                                                                 (bit-string->bytes payload)))))
-		   (else #f)))
-		(else #f))]
-	     [(message (udp-datagram src-ip src-port dst-ip dst-port bs))
-	      #:when (set-member? local-ips src-ip)
-	      (let* ((payload (bit-string (src-port :: integer bytes 2)
-					  (dst-port :: integer bytes 2)
-					  ((+ 8 (bit-string-byte-count bs))
-					   :: integer bytes 2)
-					  (0 :: integer bytes 2) ;; checksum location
-					  (bs :: binary)))
-		     (pseudo-header (bit-string (src-ip :: binary bytes 4)
-						(dst-ip :: binary bytes 4)
-						0
-						PROTOCOL-UDP
-						((bit-string-byte-count payload)
-						 :: integer bytes 2)))
-		     (checksummed-payload (ip-checksum #:pseudo-header pseudo-header
-						       6 payload)))
-		(transition local-ips (message (ip-packet #f
-                                                          src-ip
-                                                          dst-ip
-                                                          PROTOCOL-UDP
-                                                          #""
-                                                          checksummed-payload))))]
-	     [_ #f]))
-	 (set)
-	 (scn/union (advertisement (ip-packet #f ? ? PROTOCOL-UDP ? ?))
-                    (subscription (ip-packet ? ? ? PROTOCOL-UDP ? ?))
-                    (subscription (udp-datagram ? ? ? ? ?))
-                    observe-local-ip-addresses-gestalt)))

examples/operational-transformation/.gitignore

@@ -1 +0,0 @@
-compiled/

examples/operational-transformation/README.md

@@ -1,11 +0,0 @@
-# Operational Transformation
-
-The program `syndicate-server.rkt` is a port of
-[`server.rkt`](https://github.com/tonyg/racket-operational-transformation/blob/master/operational-transformation-demo/server.rkt)
-to Syndicate.
-
-It accepts the same command-line arguments, and works with unmodified
-[clients](https://github.com/tonyg/racket-operational-transformation/blob/master/operational-transformation-demo/client.rkt);
-see the
-[README](https://github.com/tonyg/racket-operational-transformation/blob/master/README.md)
-for more information.

examples/operational-transformation/syndicate-multiserver.rkt

@@ -1,106 +0,0 @@
-#lang syndicate
-
-(require racket/file)
-(require racket/serialize)
-(require racket/set)
-(require operational-transformation)
-(require operational-transformation/text/simple-document)
-
-(require syndicate/protocol/advertise)
-(require/activate syndicate/drivers/tcp)
-(require/activate syndicate/drivers/line-reader)
-
-(struct snapshot-for (filename snap) #:prefab)
-(struct proposed-op (filename p) #:prefab)
-(struct accepted-op (filename p) #:prefab)
-(struct client-seen-up-to (filename revision) #:prefab)
-
-(define cmdline-port (make-parameter 5889))
-(define cmdline-filenames (make-parameter '()))
-
-(spawn* (for [(filename (cmdline-filenames))]
-          (run-one-server filename)))
-
-(define (run-one-server filename)
-  (spawn (field [state (make-server (simple-document
-                                     (if (file-exists? filename)
-                                         (begin (log-info "loading ~v" filename)
-                                                (file->string filename))
-                                         (begin (log-info "will create ~v" filename)
-                                                ""))))])
-         (assert (snapshot-for filename (extract-snapshot (state))))
-
-         (define/query-set client-seen-revs (client-seen-up-to filename $rev) rev)
-         (field [oldest-needed-rev #f])
-         (begin/dataflow
-           (define min-rev
-             (or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
-                   (min (or min-rev rev) rev))
-                 (server-state-revision (state))))
-           (when (not (equal? (oldest-needed-rev) min-rev))
-             (oldest-needed-rev min-rev)
-             (state (forget-operation-history (state) min-rev))))
-
-         (begin/dataflow
-           (display-to-file (simple-document-text (server-state-document (state)))
-                            filename
-                            #:exists 'replace))
-
-         (on (message (proposed-op filename $p))
-             (state (incorporate-operation-from-client (state) p))
-             (define sp (extract-operation (state)))
-             (when sp (send! (accepted-op filename sp))))))
-
-(spawn (define s (tcp-listener (cmdline-port)))
-       (on-start (log-info "listening on port ~v" (cmdline-port)))
-       (assert (advertise (observe (tcp-channel _ s _))))
-       (during/spawn (advertise (tcp-channel $c s _))
-                     (assert (advertise (tcp-channel s c _)))
-                     (on-start (log-info "~a: connected" c))
-                     (on-stop (log-info "~a: disconnected" c))
-                     (connection-react c s)))
-
-(define (connection-react c s)
-  (define (output v)
-    ;; (log-info "~a: sending them ~v" c v)
-    (define p (open-output-bytes))
-    (write (serialize v) p)
-    (newline p)
-    (send! (tcp-channel s c (get-output-bytes p))))
-
-  (field [seen-up-to 0])
-  (field [selected-filename #f])
-
-  (assert #:when (selected-filename) (client-seen-up-to (selected-filename) (seen-up-to)))
-
-  (define/query-set available-filenames (observe (proposed-op $f _)) f)
-  (begin/dataflow
-    (output (set->list (available-filenames))))
-
-  (begin/dataflow
-    (when (selected-filename)
-      (log-info "~a: attached to file ~a" c (selected-filename))
-      (let-event [(asserted (snapshot-for (selected-filename) $snapshot))]
-        (output snapshot)
-        (seen-up-to (server-snapshot-revision snapshot)))))
-  (on #:when (selected-filename)
-      (message (accepted-op (selected-filename) $p))
-      (output p))
-
-  (on (message (tcp-channel-line c s $line))
-      (match (deserialize (read (open-input-bytes line)))
-        [(? string? new-filename)
-         (when (selected-filename) (log-info "~a: detached from file ~a" c (selected-filename)))
-         (seen-up-to 0)
-         (selected-filename new-filename)]
-        [(? number? n) (seen-up-to n)]
-        [(? pending-operation? p) (send! (proposed-op (selected-filename) p))])))
-
-(module+ main
-  (require racket/cmdline)
-  (command-line
-   #:once-each
-   [("-p" "--port") server-port ((format "Server port (default ~v)" (cmdline-port)))
-    (cmdline-port (string->number server-port))]
-   #:args filenames
-   (cmdline-filenames filenames)))

examples/operational-transformation/syndicate-server.rkt

@@ -1,88 +0,0 @@
-#lang syndicate
-
-(require racket/file)
-(require racket/serialize)
-(require operational-transformation)
-(require operational-transformation/text/simple-document)
-
-(require syndicate/protocol/advertise)
-(require/activate syndicate/drivers/tcp)
-(require/activate syndicate/drivers/line-reader)
-
-(struct proposed-op (p) #:prefab)
-(struct accepted-op (p) #:prefab)
-(struct client-seen-up-to (revision) #:prefab)
-
-(define cmdline-port (make-parameter 5888))
-(define cmdline-filename (make-parameter "info.rkt"))
-
-(spawn (field [state (make-server (simple-document
-                                   (if (file-exists? (cmdline-filename))
-                                       (begin (log-info "loading ~v" (cmdline-filename))
-                                              (file->string (cmdline-filename)))
-                                       (begin (log-info "will create ~v" (cmdline-filename))
-                                              ""))))])
-       (assert (extract-snapshot (state)))
-
-       (define/query-set client-seen-revs (client-seen-up-to $rev) rev)
-       (field [oldest-needed-rev #f])
-       (begin/dataflow
-         (define min-rev
-           (or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
-                 (min (or min-rev rev) rev))
-               (server-state-revision (state))))
-         (when (not (equal? (oldest-needed-rev) min-rev))
-           (oldest-needed-rev min-rev)
-           (state (forget-operation-history (state) min-rev))))
-
-       (begin/dataflow
-         (display-to-file (simple-document-text (server-state-document (state)))
-                          (cmdline-filename)
-                          #:exists 'replace))
-
-       (on (message (proposed-op $p))
-           (state (incorporate-operation-from-client (state) p))
-           (define sp (extract-operation (state)))
-           (when sp (send! (accepted-op sp)))))
-
-(spawn (define s (tcp-listener (cmdline-port)))
-       (on-start (log-info "listening on port ~v" (cmdline-port)))
-       (assert (advertise (observe (tcp-channel _ s _))))
-       (during/spawn (advertise (tcp-channel $c s _))
-                     (assert (advertise (tcp-channel s c _)))
-                     (on-start (log-info "~a: connected" c))
-                     (on-stop (log-info "~a: disconnected" c))
-                     (connection-react c s (cmdline-filename))))
-
-(define (connection-react c s filename)
-  (define (output v)
-    ;; (log-info "~a: sending them ~v" c v)
-    (define p (open-output-bytes))
-    (write (serialize v) p)
-    (newline p)
-    (send! (tcp-channel s c (get-output-bytes p))))
-
-  (field [seen-up-to 0])
-  (assert (client-seen-up-to (seen-up-to)))
-
-  (on-start
-   (output filename)
-   (let-event [(asserted ($ snapshot (server-snapshot _ _)))]
-              (output snapshot)
-              (seen-up-to (server-snapshot-revision snapshot))
-              (react (on (message (accepted-op $p))
-                         (output p)))))
-
-  (on (message (tcp-channel-line c s $line))
-      (match (deserialize (read (open-input-bytes line)))
-        [(? number? n) (seen-up-to n)]
-        [(? pending-operation? p) (send! (proposed-op p))])))
-
-(module+ main
-  (require racket/cmdline)
-  (command-line
-   #:once-each
-   [("-p" "--port") server-port ((format "Server port (default ~v)" (cmdline-port)))
-    (cmdline-port (string->number server-port))]
-   #:args (filename)
-   (cmdline-filename filename)))

examples/platformer/.gitignore

@@ -1 +0,0 @@
-compiled/

examples/platformer/hll-main.rkt

@@ -1,819 +0,0 @@
-#lang syndicate
-
-(require 2htdp/image)
-(require 2htdp/planetcute)
-
-(require racket/set)
-(require plot/utils) ;; for vector utilities
-
-(require (only-in racket/string string-prefix?))
-(require (only-in racket/gui/base play-sound))
-
-(require/activate syndicate/drivers/timer)
-
-(require syndicate-gl/2d)
-(module+ main (current-ground-dataspace (2d-dataspace #:width 600 #:height 400)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Layers:
-;;
-;; - External I/O
-;;   as arranged by syndicate-gl/2d
-;;   including keyboard events, interface to rendering, and frame timing
-;;
-;; - Ground
-;;   corresponds to computer itself
-;;   device drivers
-;;   applications (e.g. in this instance, the game)
-;;
-;; - Game
-;;   running application
-;;   per-game state, such as score and count-of-deaths
-;;   process which spawns levels
-;;   regular frame ticker
-;;
-;; - Level
-;;   model of the game world
-;;   actors represent entities in the world, mostly
-;;   misc actors do physicsish things
-;;
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ## Common Data Definitions
-;;
-;; A Vec is a (vector Number Number)
-;; A Point is a (vector Number Number)
-;; (See vector functions in plot/utils)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ## Ground Layer Protocols
-
-;;-------------------------------------------------------------------------
-;; ### Scene Management
-;;     - assertion: ScrollOffset
-;;     - assertion: OnScreenDisplay
-;;     - role: SceneManager
-;;         Displays the scene backdrop and adjusts display coordinates via ScrollOffset.
-;;
-;; A ScrollOffset is a (scroll-offset Vec), indicating the vector to *subtract*
-;; from world coordinates to get device coordinates.
-(struct scroll-offset (vec) #:transparent)
-;;
-;; An OnScreenDisplay is an (on-screen-display Number Number (Seal Image)),
-;; representing an item to display in a fixed window-relative position
-;; above the scrolled part of the scene. If the coordinates are
-;; positive, they measure right/down from the left/top of the image;
-;; if negative, they measure left/up from the right/bottom.
-(struct on-screen-display (x y sealed-image) #:transparent)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ## Game Layer Protocols
-
-;;-------------------------------------------------------------------------
-;; ### Scoring
-;;     - message: AddToScore
-;;     - assertion: CurrentScore
-;;     - role: ScoreKeeper
-;;         Maintains the score as private state.
-;;         Publishes the score using a CurrentScore.
-;;         Responds to AddToScore by updating the score.
-;;
-;; An AddToScore is an (add-to-score Number), a message
-;; which signals a need to add the given number to the player's
-;; current score.
-(struct add-to-score (delta) #:transparent)
-;;
-;; A CurrentScore is a (current-score Number), an assertion
-;; indicating the player's current score.
-(struct current-score (value) #:transparent)
-
-;;-------------------------------------------------------------------------
-;; ### Level Spawning
-;;     - assertion: LevelRunning
-;;     - message: LevelCompleted
-;;     - role: LevelSpawner
-;;         Maintains the current level number as private state.
-;;         Spawns a new Level when required.
-;;         Monitors LevelRunning - when it drops, the level is over.
-;;         Receives LevelCompleted messages. If LevelRunning drops without
-;;         a LevelCompleted having arrived, the level ended in failure and
-;;         should be restarted. If LevelComplete arrived before LevelRunning
-;;         dropped, the level was completed successfully, and the next level
-;;         should be presented.
-;;     - role: Level
-;;         Running level instance. Maintains LevelRunning while it's still
-;;         going. Sends LevelCompleted if the player successfully completed
-;;         the level.
-;;
-;; A LevelRunning is a (level-running), an assertion indicating that the
-;; current level is still in progress.
-(struct level-running () #:transparent)
-;;
-;; A LevelCompleted is a (level-completed), a message indicating that
-;; the current level was *successfully* completed before it terminated.
-(struct level-completed () #:transparent)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ## Level Layer Protocols
-
-;;-------------------------------------------------------------------------
-;; ### Movement and Physics
-;;     - message: JumpRequest
-;;     - assertion: Impulse
-;;     - assertion: Position
-;;     - assertion: GamePieceConfiguration
-;;     - assertion: Touching
-;;     - role: PhysicsEngine
-;;         Maintains positions, velocities and accelerations of all GamePieces.
-;;         Uses GamePieceConfiguration for global properties of pieces.
-;;         Publishes Position to match.
-;;         Listens to FrameDescription, using it to advance the simulation.
-;;         Considers only mobile GamePieces for movement.
-;;         Takes Impulses as the baseline for moving GamePieces around.
-;;         For massive mobile GamePieces, applies gravitational acceleration.
-;;         Computes collisions between GamePieces.
-;;         Uses Attributes of GamePieces to decide what to do in response to collisions.
-;;         For 'touchable GamePieces, a Touching row is asserted.
-;;         Responds to JumpRequest by checking whether the named piece is in a
-;;         jumpable location, and sets its upward velocity negative if so.
-;;     - role: GamePiece
-;;         Maintains private state. Asserts Impulse to move around,
-;;         and GamePieceConfiguration to get things started. May issue
-;;         JumpRequests at any time. Represents both the player,
-;;         enemies, the goal(s), and platforms and blocks in the
-;;         environment. Asserts a Sprite two layers out to render
-;;         itself.
-;;
-;; An ID is a Symbol; the special symbol 'player indicates the player's avatar.
-;; Gensyms from (gensym 'enemy) name enemies, etc.
-;;
-;; A JumpRequest is a (jump-request ID), a message indicating a *request* to jump,
-;; not necessarily honoured by the physics engine.
-(struct jump-request (id) #:transparent)
-;;
-;; An Impulse is an (impulse ID Vec), an assertion indicating a contribution to
-;; the net *requested* velocity of the given gamepiece.
-(struct impulse (id vec) #:transparent)
-;;
-;; A Position is a (position ID Point Vec), an assertion describing
-;; the current actual top-left corner and (physics-related, not
-;; necessarily graphics-related) size of the named gamepiece.
-(struct position (id top-left size) #:transparent)
-;;
-;; An Attribute is either
-;;  - 'player - the named piece is a player avatar
-;;  - 'touchable - the named piece reacts to the player's touch
-;;  - 'solid - the named piece can be stood on / jumped from
-;;  - 'mobile - the named piece is not fixed in place
-;;  - 'massive - the named piece is subject to effects of gravity
-;;               (it is an error to be 'massive but not 'mobile)
-;;
-;; A GamePieceConfiguration is a
-;;  - (game-piece-configuration ID Point Vec (Set Attribute))
-;; an assertion specifying not only the *existence* of a named
-;; gamepiece, but also its initial position and size and a collection
-;; of its Attributes.
-(struct game-piece-configuration (id initial-position size attributes) #:transparent)
-;;
-;; A Touching is a
-;;  - (touching ID ID Side)
-;; an assertion indicating that the first ID is touching the second on
-;; the named side of the second ID.
-(struct touching (a b side) #:transparent)
-;;
-;; A Side is either 'top, 'left, 'right, 'bottom or the special value
-;; 'mid, indicating an unknown or uncomputable side.
-
-(define (game-piece-has-attribute? g attr)
-  (set-member? (game-piece-configuration-attributes g) attr))
-
-;;-------------------------------------------------------------------------
-;; ### Player State
-;;     - message: Damage
-;;     - assertion: Health
-;;     - role: Player
-;;         Maintains hitpoints, which it reflects using Health.
-;;         Responds to Damage.
-;;         When hitpoints drop low enough, removes the player from the board.
-;;
-;; A Damage is a (damage ID Number), a message indicating an event that should
-;; consume the given number of health points of the named gamepiece.
-(struct damage (id hit-points) #:transparent)
-;;
-;; A Health is a (health ID Number), an assertion describing the current hitpoints
-;; of the named gamepiece.
-(struct health (id hit-points) #:transparent)
-
-;;-------------------------------------------------------------------------
-;; ### World State
-;;     - assertion: LevelSize
-;;     - role: DisplayControl
-;;         Maintains a LevelSize assertion.
-;;         Observes the Position of the player, and computes and maintains a
-;;         ScrollOffset two layers out, to match.
-;;         Also kills the player if they wander below the bottom of the level.
-;;
-;; A LevelSize is a (level-size Vec), an assertion describing the right-hand and
-;; bottom edges of the level canvas (in World coordinates).
-(struct level-size (vec) #:transparent)
-
-;; -----------
-;; Interaction Diagrams (to be refactored into the description later)
-;;
-;; ================================================================================
-;;
-;; title Jump Sequence
-;;
-;; Player -> Physics: (jump 'player)
-;; note right of Physics: Considers the request.
-;; note right of Physics: Denied -- Player is not on a surface.
-;;
-;; Player -> Physics: (jump 'player)
-;; note right of Physics: Considers the request.
-;; note right of Physics: Accepted.
-;; note right of Physics: Updates velocity, position
-;; Physics -> Subscribers: (vel 'player ...)
-;; Physics -> Subscribers: (pos 'player ...)
-;;
-;;
-;; ================================================================================
-;;
-;; title Display Control Updates
-;;
-;; Physics -> DisplayCtl: (pos 'player ...)
-;; note right of DisplayCtl: Compares player pos to level size
-;; DisplayCtl -> Subscribers: (inbound (inbound (scroll-offset ...)))
-;;
-;; ================================================================================
-;;
-;; title Movement Sequence
-;;
-;; Moveable -> Physics: (mobile ID Boolean)
-;; Moveable -> Physics: (attr ID ...)
-;; Moveable -> Physics: (impulse ID vec)
-;; note right of Physics: Processes simulation normally
-;; Physics -> Subscribers: (pos ID ...)
-;; Physics -> Subscribers: (vel ID ...)
-;;
-;; ================================================================================
-;;
-;; title Keyboard Interpretation
-;;
-;; Keyboard -> Player: (press right-arrow)
-;; Player -->> Physics: assert (impulse ID (vec DX 0))
-;;
-;; note right of Physics: Processes simulation normally
-;;
-;; Keyboard -> Player: (press left-arrow)
-;; Player -->> Physics: assert (impulse ID (vec 0 0))
-;;
-;; Keyboard -> Player: (release right-arrow)
-;; Player -->> Physics: assert (impulse ID (vec -DX 0))
-;;
-;; Keyboard -> Player: (press space)
-;; Player -> Physics: (jump)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Icon
-
-(struct icon (pict scale hitbox-width-fraction hitbox-height-fraction baseline-fraction)
-  #:transparent)
-
-(define (icon-width i) (* (image-width (icon-pict i)) (icon-scale i)))
-(define (icon-height i) (* (image-height (icon-pict i)) (icon-scale i)))
-(define (icon-hitbox-width i) (* (icon-width i) (icon-hitbox-width-fraction i)))
-(define (icon-hitbox-height i) (* (icon-height i) (icon-hitbox-height-fraction i)))
-(define (icon-hitbox-size i) (vector (icon-hitbox-width i) (icon-hitbox-height i)))
-
-(define (focus->top-left i x y)
-  (vector (- x (/ (icon-hitbox-width i) 2))
-          (- y (icon-hitbox-height i))))
-
-(define (icon-sprite i layer pos)
-  (match-define (vector x y) pos)
-  (simple-sprite layer
-                 (- x (/ (- (icon-width i) (icon-hitbox-width i)) 2))
-                 (- y (- (* (icon-baseline-fraction i) (icon-height i)) (icon-hitbox-height i)))
-                 (icon-width i)
-                 (icon-height i)
-                 (icon-pict i)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; SceneManager
-
-(define (spawn-scene-manager)
-  (spawn #:name 'scene-manager
-         (define backdrop (rectangle 1 1 "solid" "white"))
-
-         (define/query-value size (vector 0 0) (inbound (window $x $y)) (vector x y))
-         (define/query-set osds ($ o (on-screen-display _ _ _)) o)
-         (define/query-value offset (vector 0 0) (scroll-offset $v) v)
-
-         (field [fullscreen? #f])
-         (assert #:when (fullscreen?) (outbound 'fullscreen))
-         (on (message (inbound (key-event #\f #t _)))
-             (fullscreen? (not (fullscreen?))))
-
-         (define (compute-backdrop)
-           (match-define (vector width height) (size))
-           (match-define (vector ofs-x ofs-y) (offset))
-           (define osd-blocks
-             (for/list [(osd (in-set (osds)))]
-               (match-define (on-screen-display raw-x raw-y (seal i)) osd)
-               (define x (if (negative? raw-x) (+ width raw-x) raw-x))
-               (define y (if (negative? raw-y) (+ height raw-y) raw-y))
-               `(push-matrix (translate ,x ,y)
-                             (scale ,(image-width i) ,(image-height i))
-                             (texture ,i))))
-           (scene (seal `((push-matrix
-                           (scale ,width ,height)
-                           (texture ,backdrop))
-                          (translate ,(- ofs-x) ,(- ofs-y))))
-                  (seal `((translate ,ofs-x ,ofs-y)
-                          ,@osd-blocks))))
-         (assert (outbound (compute-backdrop)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; ScoreKeeper
-
-(define (spawn-score-keeper)
-  (spawn #:name 'score-keeper
-         (field [score 0])
-         (assert (current-score (score)))
-         (assert (outbound
-                  (on-screen-display -150 10
-                                     (seal (text (format "Score: ~a" (score)) 24 "white")))))
-         (on (message (add-to-score $delta))
-             (score (+ (score) delta))
-             (log-info "Score increased by ~a to ~a" delta (score))
-             (play-sound-sequence 270304))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; PhysicsEngine
-
-(define impulse-multiplier 0.360) ;; 360 pixels per second
-(define jump-vel (vector 0 -2))
-(define gravity 0.004)
-
-(define (spawn-physics-engine)
-  (spawn #:name 'physics-engine
-   (field [configs (hash)]
-          [previous-positions (hash)]
-          [previous-velocities (hash)]
-          [positions (hash)]
-          [velocities (hash)])
-
-   (during (game-piece-configuration $id $initial-position $size $attrs)
-           (on-start (configs
-                      (hash-set (configs) id
-                                (game-piece-configuration id initial-position size attrs))))
-           (on-stop (configs (hash-remove (configs) id))
-                    (positions (hash-remove (positions) id))
-                    (velocities (hash-remove (velocities) id)))
-           (assert (position id (hash-ref (positions) id initial-position) size)))
-
-   (define/query-hash impulses (impulse $id $vec) id vec)
-
-   (define (piece-cfg id) (hash-ref (configs) id))
-   (define (piece-pos which id)
-     (hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id)))))
-   (define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0))))
-   (define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0))))
-
-   (define (update-piece! g new-pos new-vel)
-     (positions (hash-set (positions) (game-piece-configuration-id g) new-pos))
-     (velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel)))
-
-   (define (find-support p size which-pos)
-     (match-define (vector p-left p-top) p)
-     (match-define (vector p-w p-h) size)
-     (define p-right (+ p-left p-w))
-     (define p-bottom (+ p-top p-h))
-     (for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
-       (match-define (vector left top) (piece-pos which-pos id))
-       (and (< (abs (- top p-bottom)) 0.5)
-            (<= left p-right)
-            (match (game-piece-configuration-size g)
-              [(vector w h)
-               (<= p-left (+ left w))])
-            g)))
-
-   (define (segment-intersection-time p0 r q0 q1)
-     ;; See http://stackoverflow.com/a/565282/169231
-     ;; Enhanced to consider the direction of impact with the segment,
-     ;; too: only returns an intersection when the vector of motion is
-     ;; at an obtuse angle to the normal of the segment.
-     (define s (v- q1 q0))
-     (define rxs (vcross2 r s))
-     (cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear)
-           [else
-            (define q-p (v- q0 p0))
-            (define q-pxs (vcross2 q-p s))
-            (define t (/ q-pxs rxs))
-            (and (<= 0 t 1)
-                 (let* ((q-pxr (vcross2 q-p r))
-                        (u (/ q-pxr rxs)))
-                   (and (< 0 u 1)
-                        (let* ((q-norm
-                                (vnormalize (vector (vector-ref s 1) (- (vector-ref s 0))))))
-                          (and (not (positive? (vdot r q-norm)))
-                               (- t 0.001))))))]))
-
-   (define (three-corners top-left size)
-     (match-define (vector w h) size)
-     (values (v+ top-left (vector w 0))
-             (v+ top-left size)
-             (v+ top-left (vector 0 h))))
-
-   (define (clip-movement-by top-left moved-top-left size solid-top-left solid-size)
-     (define-values (solid-top-right solid-bottom-right solid-bottom-left)
-       (three-corners solid-top-left solid-size))
-     (define-values (top-right bottom-right bottom-left)
-       (three-corners top-left size))
-     (define r (v- moved-top-left top-left))
-     (define t
-       (apply min
-              (for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))]
-                (min (or (segment-intersection-time p r solid-top-left solid-top-right) 1)
-                     ;; TODO: some means of specifying *which edges* should appear solid.
-                     #;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1)
-                     #;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1)
-                     #;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1)))))
-     (v+ top-left (v* r t)))
-
-   (define (clip-movement-by-solids p0 p1 size)
-     (for/fold [(p1 p1)]
-               [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
-       (clip-movement-by p0 p1 size
-                         (piece-pos previous-positions id)
-                         (game-piece-configuration-size g))))
-
-   (define (touched-during-movement? TL moved-TL size touchable-TL touchable-size)
-     (define r (v- moved-TL TL))
-     (if (positive? (vmag^2 r)) ;; r is nonzero, in other words
-         (let ()
-           (define-values (touchable-TR touchable-BR touchable-BL)
-             (three-corners touchable-TL touchable-size))
-           (define-values (TR BR BL)
-             (three-corners TL size))
-           (for/or [(p (in-list (list TL TR BR BL)))]
-             (or
-              (and (segment-intersection-time p r touchable-TR touchable-BR) 'right)
-              (and (segment-intersection-time p r touchable-BR touchable-BL) 'bottom)
-              (and (segment-intersection-time p r touchable-BL touchable-TL) 'left)
-              (and (segment-intersection-time p r touchable-TL touchable-TR) 'top))))
-         (let ()
-           (match-define (vector left top) TL)
-           (match-define (vector touchable-left touchable-top) touchable-TL)
-           (match-define (vector width height) size)
-           (match-define (vector touchable-width touchable-height) touchable-size)
-           (and (<= left (+ touchable-left touchable-width))
-                (<= top (+ touchable-top touchable-height))
-                (<= touchable-left (+ left width))
-                (<= touchable-top (+ top height))
-                'mid))))
-
-   (define (touchables-touched-during-movement p0 p1 size)
-     (for/fold [(ts '())]
-               [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'touchable)]
-       (define side (touched-during-movement? p0 p1 size
-                                              (piece-pos previous-positions id)
-                                              (game-piece-configuration-size g)))
-       (if side (cons (cons side g) ts) ts)))
-
-   (define (update-game-piece! elapsed-ms id)
-     (define g (piece-cfg id))
-     (define size (game-piece-configuration-size g))
-     (define pos0 (piece-pos previous-positions id))
-     (define support (find-support pos0 size previous-positions))
-
-     (define vel0 (piece-vel previous-velocities id))
-     (define imp0 (piece-imp id))
-
-     (define vel1 (cond
-                    [(and support (not (negative? (vector-ref vel0 1))))
-                     (piece-vel previous-velocities (game-piece-configuration-id support))]
-                    [(game-piece-has-attribute? g 'massive)
-                     (v+ vel0 (vector 0 (* gravity elapsed-ms)))]
-                    [else
-                     vel0]))
-
-     (define pos1 (v+ pos0 (v* (v+ vel1 imp0) (* impulse-multiplier elapsed-ms))))
-     (define final-pos (clip-movement-by-solids pos0 pos1 size))
-     ;; TODO: figure out how to cancel just the component of velocity blocked by the obstacle(s)
-     ;; - which will avoid the "sticking to the wall" artifact
-     (define final-vel (if (v= pos1 final-pos) vel1 (vector 0 0))) ;; stop at collision
-     (define touchables (touchables-touched-during-movement pos0 final-pos size))
-
-     (retract! (touching id ? ?))
-     (for [(t touchables)]
-       (match-define (cons side tg) t)
-       (assert! (touching id (game-piece-configuration-id tg) side)))
-     (update-piece! g final-pos final-vel))
-
-   (on (message (jump-request $id))
-       (define g (piece-cfg id))
-       (define pos (piece-pos positions id))
-       (when (find-support pos (game-piece-configuration-size g) positions)
-         (play-sound-sequence 270318)
-         (update-piece! g pos jump-vel)))
-
-   (on (message (inbound* game-level (frame-event $counter _ $elapsed-ms _)))
-       (when (zero? (modulo counter 10))
-         (log-info "Instantaneous frame rate at frame ~a: ~a Hz"
-                   counter
-                   (/ 1000.0 elapsed-ms)))
-       (previous-positions (positions))
-       (previous-velocities (velocities))
-       (for [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'mobile)]
-         (update-game-piece! elapsed-ms id)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Player
-
-(define player-id 'player)
-(define planetcute-scale 1/2)
-
-(define (spawn-player-avatar initial-focus-x initial-focus-y)
-  (spawn #:name 'player-avatar
-   (define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16))
-   (define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
-
-   (assert (game-piece-configuration player-id
-                                     initial-top-left
-                                     (icon-hitbox-size i)
-                                     (set 'player 'mobile 'massive)))
-
-   (define/query-value pos initial-top-left (position player-id $hitbox-top-left _)
-     hitbox-top-left)
-   (assert (outbound* game-level (icon-sprite i 0 (pos))))
-
-   (field [hit-points 1])
-   (assert (health player-id (hit-points)))
-   (stop-when-true (<= (hit-points) 0))
-   (on (message (damage player-id $amount))
-       (hit-points (- (hit-points) amount)))
-
-   (on (asserted (inbound* 2 (key-pressed #\space))) (send! (jump-request player-id)))
-   (on (asserted (inbound* 2 (key-pressed #\.)))     (send! (jump-request player-id)))
-
-   (define/query-set keys-down (inbound* 2 (key-pressed $k)) k)
-   (define (any-key-down? . ks) (for/or [(k ks)] (set-member? (keys-down) k)))
-   (assert (impulse player-id (vector (+ (if (any-key-down? 'left 'prior) -1 0)
-                                         (if (any-key-down? 'right 'next) 1 0))
-                                      0)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Ground Block
-
-(define (spawn-ground-block top-left size #:color [color "purple"])
-  (spawn #:name (list 'ground-block top-left size color)
-         (match-define (vector x y) top-left)
-         (match-define (vector w h) size)
-         (define block-id (gensym 'ground-block))
-         (define block-pict (rectangle w h "solid" color))
-         (assert (outbound* game-level (simple-sprite 0 x y w h block-pict)))
-         (assert (game-piece-configuration block-id
-                                            top-left
-                                            size
-                                            (set 'solid)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Goal piece
-;;
-;; When the player touches a goal, sends LevelCompleted one layer out.
-
-(define (spawn-goal-piece initial-focus-x initial-focus-y)
-  (define goal-id (gensym 'goal))
-
-  (define i (icon key planetcute-scale 1/3 2/5 4/5))
-  (define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
-
-  (spawn #:name (list 'goal-piece initial-focus-x initial-focus-y)
-         (on (asserted (touching player-id goal-id _))
-             (send! (outbound (level-completed))))
-         (assert (game-piece-configuration goal-id
-                                           initial-top-left
-                                           (icon-hitbox-size i)
-                                           (set 'touchable)))
-         (assert (outbound* game-level (icon-sprite i -1 initial-top-left)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Enemy
-
-(define (spawn-enemy initial-x initial-y range-lo range-hi
-                     #:speed [speed 0.2]
-                     #:facing [initial-facing 'right])
-  (spawn #:name (list 'enemy initial-x initial-y initial-facing)
-   (define enemy-id (gensym 'enemy))
-   (define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6))
-   (define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))]))
-   (define initial-top-left (focus->top-left i initial-x initial-y))
-   (match-define (vector width height) (icon-hitbox-size i))
-
-   (assert (game-piece-configuration enemy-id
-                                     initial-top-left
-                                     (icon-hitbox-size i)
-                                     (set 'mobile 'massive 'touchable)))
-
-   (define/query-value current-level-size #f (level-size $v) v)
-
-   (define/query-value pos initial-top-left (position enemy-id $top-left _) top-left
-     #:on-add (match-let (((vector left top) top-left))
-                (facing (cond [(< left range-lo) 'right]
-                              [(> (+ left width) range-hi) 'left]
-                              [else (facing)]))))
-
-   (stop-when-true (and (current-level-size)
-                        (> (vector-ref (pos) 1)
-                           (vector-ref (current-level-size) 1))))
-
-   (field [facing initial-facing])
-   (assert (outbound* game-level
-                      (icon-sprite (match (facing) ['right i] ['left i-flipped]) -1 (pos))))
-
-   (assert (impulse enemy-id (vector (* speed (match (facing) ['right 1] ['left -1])) 0)))
-
-   (stop-when (asserted (touching player-id enemy-id 'top))
-              (play-sound-sequence 270325)
-              (send! (outbound (add-to-score 1))))
-
-   (on (asserted (touching player-id enemy-id $side))
-       (when (not (eq? side 'top)) (send! (damage player-id 1))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; DisplayControl
-
-(define (spawn-display-controller level-size-vec)
-  (match-define (vector level-width level-height) level-size-vec)
-
-  (spawn #:name 'display-controller
-   (field [offset-pos (vector 0 0)])
-   (assert (outbound* 2 (scroll-offset (offset-pos))))
-   (assert (level-size level-size-vec))
-
-   (define/query-value window-size-vec #f (inbound* game-level (window $w $h)) (vector w h))
-
-   (define (compute-offset pos viewport limit)
-     (min (max 0 (- pos (/ viewport 2))) (- limit viewport)))
-
-   (on (asserted (position player-id (vector $px $py) _))
-       (when (window-size-vec)
-         (match-define (vector ww wh) (window-size-vec))
-         (when (> py level-height) (send! (damage player-id +inf.0)))
-         (offset-pos (vector (compute-offset px ww level-width)
-                             (compute-offset py wh level-height)))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; LevelTerminationMonitor
-;;
-;; When the player vanishes from the board, or LevelCompleted is seen,
-;; kills the dataspace.
-
-(define (wait-for-level-termination)
-  (spawn
-   (assert (outbound (level-running)))
-   (on (retracted (game-piece-configuration player-id _ _ _))
-       (log-info "Player died! Terminating level.")
-       (play-sound-sequence 270328)
-       (quit-dataspace!))
-   (on (message (inbound (level-completed)))
-       (log-info "Level completed! Terminating level.")
-       (play-sound-sequence 270330)
-       (send! (outbound (add-to-score 100)))
-       (quit-dataspace!))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; LevelSpawner
-
-(define (spawn-standalone-assertions . patches)
-  (spawn #:name 'standalone-assertions
-         (on-start (patch! (patch-seq* patches)))))
-
-(define (spawn-background-image level-size scene)
-  (match-define (vector level-width level-height) level-size)
-  (define scene-width (image-width scene))
-  (define scene-height (image-height scene))
-  (define level-aspect (/ level-width level-height))
-  (define scene-aspect (/ scene-width scene-height))
-  (define scale (if (> level-aspect scene-aspect) ;; level is wider, proportionally, than scene
-                    (/ level-width scene-width)
-                    (/ level-height scene-height)))
-  (spawn-standalone-assertions
-   (update-sprites #:meta-level game-level
-                   (sprite 10
-                           `((scale ,(* scene-width scale)
-                                    ,(* scene-height scale))
-                             (texture ,scene))))))
-
-;; http://www.travelization.net/wp-content/uploads/2012/07/beautiful-grassland-wallpapers-1920x1080.jpg
-(define grassland-backdrop (bitmap "beautiful-grassland-wallpapers-1920x1080.jpg"))
-
-(define (spawn-level #:initial-player-x [initial-player-x 50]
-                     #:initial-player-y [initial-player-y 50]
-                     #:level-size [level-size-vec (vector 4000 2000)]
-                     #:scene [scene grassland-backdrop]
-                     actions-thunk)
-  (lambda ()
-    (dataspace (when scene (spawn-background-image level-size-vec scene))
-               (spawn-display-controller level-size-vec)
-               (spawn-physics-engine)
-               (spawn-player-avatar initial-player-x initial-player-y)
-               (actions-thunk)
-               (wait-for-level-termination))))
-
-(define standard-ground-height 50)
-
-(define (slab left top width #:color [color "purple"])
-  (spawn-ground-block (vector left top) (vector width standard-ground-height) #:color color))
-
-(define levels
-  (list
-   (spawn-level (lambda ()
-                  (slab 25 125 100)
-                  (slab 50 300 500)
-                  (spawn-enemy 100 300 50 550)
-                  (spawn-enemy 300 300 50 550 #:facing 'left)
-                  (spawn-goal-piece 570 150)
-                  (slab 850 300 50)
-                  (slab 925 400 50)
-                  (slab 975 500 50)
-                  (slab 975 600 50)
-                  (slab 500 600 150 #:color "orange")))
-   (spawn-level (lambda ()
-                  (slab 25 300 500)
-                  (slab 500 400 500)
-                  (slab 1000 500 400)
-                  (spawn-goal-piece 1380 500)))
-   (spawn-level (lambda ()
-                  (slab 25 300 1000)
-                  (spawn-enemy 600 300 25 1025 #:facing 'left)
-                  (spawn-goal-piece 980 300)))
-   (spawn-level (lambda ()
-                  (spawn-goal-piece 250 280)
-                  (spawn-enemy 530 200 400 600)
-                  (spawn-enemy 500 200 -100 1000 #:facing 'left)
-                  (slab 400 200 200)
-                  (spawn-ground-block (vector 200 280) (vector 200 200) #:color "orange")
-                  (slab 25 300 500)
-                  (slab 600 1300 600)
-                  (slab 1150 1200 25 #:color "red")
-                  (for/list ((n 10))
-                    (slab 900 (+ 200 (* n 100)) 50)))
-                )
-   ))
-
-(define (spawn-numbered-level level-number)
-  (send! (outbound* 2 (request-gc)))
-  (if (< level-number (length levels))
-      ((list-ref levels level-number))
-      (spawn-standalone-assertions
-       (update-sprites #:meta-level 2
-                       (let ((message (text "You won!" 72 "red")))
-                         (simple-sprite 0
-                                        10
-                                        100
-                                        (image-width message)
-                                        (image-height message)
-                                        message))))))
-
-(define (spawn-level-spawner starting-level)
-  (spawn #:name 'level-spawner
-         (field [current-level starting-level]
-                [level-complete? #f])
-
-         (on (message (level-completed)) (level-complete? #t))
-
-         (on (retracted (level-running))
-             (current-level (if (level-complete?) (+ (current-level) 1) (current-level)))
-             (level-complete? #f)
-             (spawn-numbered-level (current-level)))
-
-         (on-start (spawn-numbered-level starting-level))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Sounds
-
-(define (lookup-sound-file sound-number)
-  (define sought-prefix (format "sounds/~a__" sound-number))
-  (for/or [(filename (in-directory "sounds"))]
-    (and (string-prefix? (path->string filename) sought-prefix)
-         filename)))
-
-;; TODO: make this a sound driver...
-;; TODO: ...and make sound triggering based on assertions of game
-;; state, not hardcoding in game logic
-(define (play-sound-sequence . sound-numbers)
-  (thread (lambda ()
-            (for [(sound-number (in-list sound-numbers))]
-              (define sound-file (lookup-sound-file sound-number))
-              (play-sound sound-file #f)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define game-level 3) ;; used to specify meta-level to reach external I/O
-
-(spawn-keyboard-integrator)
-(spawn-scene-manager)
-(dataspace (spawn-score-keeper)
-           (spawn-level-spawner 0))

examples/platformer/info.rkt

@@ -1,5 +0,0 @@
-#lang setup/infotab
-(define deps '("syndicate"
-               "base"
-	       "htdp-lib"
-	       ))

examples/platformer/sounds/_readme_and_license.txt

@@ -1,140 +0,0 @@
-Sound pack downloaded from Freesound.org
-----------------------------------------
-
-This pack of sounds contains sounds by LittleRobotSoundFactory ( https://www.freesound.org/people/LittleRobotSoundFactory/  )
-You can find this pack online at: https://www.freesound.org/people/LittleRobotSoundFactory/packs/16681/
-
-
-License details
----------------
-
-Sampling+: http://creativecommons.org/licenses/sampling+/1.0/
-Creative Commons 0: http://creativecommons.org/publicdomain/zero/1.0/
-Attribution: http://creativecommons.org/licenses/by/3.0/
-Attribution Noncommercial: http://creativecommons.org/licenses/by-nc/3.0/
-
-
-Sounds in this pack
--------------------
-
-  * 270344__littlerobotsoundfactory__shoot-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270344/
-    * license: Attribution
-  * 270343__littlerobotsoundfactory__shoot-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270343/
-    * license: Attribution
-  * 270342__littlerobotsoundfactory__pickup-03.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270342/
-    * license: Attribution
-  * 270341__littlerobotsoundfactory__pickup-04.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270341/
-    * license: Attribution
-  * 270340__littlerobotsoundfactory__pickup-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270340/
-    * license: Attribution
-  * 270339__littlerobotsoundfactory__pickup-02.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270339/
-    * license: Attribution
-  * 270338__littlerobotsoundfactory__open-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270338/
-    * license: Attribution
-  * 270337__littlerobotsoundfactory__pickup-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270337/
-    * license: Attribution
-  * 270336__littlerobotsoundfactory__shoot-02.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270336/
-    * license: Attribution
-  * 270335__littlerobotsoundfactory__shoot-03.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270335/
-    * license: Attribution
-  * 270334__littlerobotsoundfactory__jingle-lose-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270334/
-    * license: Attribution
-  * 270333__littlerobotsoundfactory__jingle-win-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270333/
-    * license: Attribution
-  * 270332__littlerobotsoundfactory__hit-03.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270332/
-    * license: Attribution
-  * 270331__littlerobotsoundfactory__jingle-achievement-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270331/
-    * license: Attribution
-  * 270330__littlerobotsoundfactory__jingle-achievement-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270330/
-    * license: Attribution
-  * 270329__littlerobotsoundfactory__jingle-lose-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270329/
-    * license: Attribution
-  * 270328__littlerobotsoundfactory__hero-death-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270328/
-    * license: Attribution
-  * 270327__littlerobotsoundfactory__hit-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270327/
-    * license: Attribution
-  * 270326__littlerobotsoundfactory__hit-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270326/
-    * license: Attribution
-  * 270325__littlerobotsoundfactory__hit-02.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270325/
-    * license: Attribution
-  * 270324__littlerobotsoundfactory__menu-navigate-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270324/
-    * license: Attribution
-  * 270323__littlerobotsoundfactory__jump-03.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270323/
-    * license: Attribution
-  * 270322__littlerobotsoundfactory__menu-navigate-02.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270322/
-    * license: Attribution
-  * 270321__littlerobotsoundfactory__menu-navigate-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270321/
-    * license: Attribution
-  * 270320__littlerobotsoundfactory__jump-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270320/
-    * license: Attribution
-  * 270319__littlerobotsoundfactory__jingle-win-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270319/
-    * license: Attribution
-  * 270318__littlerobotsoundfactory__jump-02.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270318/
-    * license: Attribution
-  * 270317__littlerobotsoundfactory__jump-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270317/
-    * license: Attribution
-  * 270316__littlerobotsoundfactory__open-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270316/
-    * license: Attribution
-  * 270315__littlerobotsoundfactory__menu-navigate-03.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270315/
-    * license: Attribution
-  * 270311__littlerobotsoundfactory__explosion-03.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270311/
-    * license: Attribution
-  * 270310__littlerobotsoundfactory__explosion-04.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270310/
-    * license: Attribution
-  * 270309__littlerobotsoundfactory__craft-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270309/
-    * license: Attribution
-  * 270308__littlerobotsoundfactory__explosion-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270308/
-    * license: Attribution
-  * 270307__littlerobotsoundfactory__explosion-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270307/
-    * license: Attribution
-  * 270306__littlerobotsoundfactory__explosion-02.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270306/
-    * license: Attribution
-  * 270305__littlerobotsoundfactory__climb-rope-loop-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270305/
-    * license: Attribution
-  * 270304__littlerobotsoundfactory__collect-point-00.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270304/
-    * license: Attribution
-  * 270303__littlerobotsoundfactory__collect-point-01.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270303/
-    * license: Attribution
-  * 270302__littlerobotsoundfactory__collect-point-02.wav
-    * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270302/
-    * license: Attribution
-

examples/webchat/NOTES.md

@@ -1,38 +0,0 @@
-## Sorting out contact states
-
-### Design
-
-Contacts are symmetric: If A follows B, then B follows A.
-
-Let's look at how the state of the A/B relationship changes:
-
- - Initial state: neither A nor B follows the other.
-    - ACTION: A adds B to their contacts
-       - A proposes an A/B link.
-          - ACTION: A may cancel the proposition
-             - Return to initial state.
-          - ACTION: B may approve the proposition
-             - A/B link established.
-          - ACTION: B may reject the proposition
-             - Return to initial state.
-          - ACTION: B may ignore the proposition
-             - B's user interface no longer displays the request,
-               but if B subsequently proposes an A/B link, it is
-               as if B approved the previously-proposed link.
-
- - From "A/B link established":
-    - ACTION: A may cancel the link
-       - Return to initial state.
-    - ACTION: B may cancel the link
-       - Return to initial state.
-
-B should appear in A's contact list in any of these cases:
-
- 1. A has proposed an A/B link.
- 2. An A/B link exists.
-
-In the first case, B should appear as a "pending link request": as
-offline, with a "cancel link request" action available.
-
-In the second case, B should appear as fully linked, either offline or
-online, with a "delete contact" action available.

examples/webchat/htdocs/Text-x-generic.svg

@@ -1,49 +0,0 @@
-<?xml version="1.0"?>
-<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" height="48px" width="48px">
-<defs>
-	<radialGradient id="b" gradientUnits="userSpaceOnUse" cy="42.1" cx="24.31" gradientTransform="matrix(1.076 0 0 .285-1.85 30.8)" r="15.82">
-		<stop offset="0"/>
-		<stop stop-opacity="0" offset="1"/>
-	</radialGradient>
-	<radialGradient id="f" gradientUnits="userSpaceOnUse" cy="35.74" cx="33.97" gradientTransform="scale(.961 1.041)" r="86.7">
-		<stop stop-color="#fafafa" offset="0"/>
-		<stop stop-color="#bbb" offset="1"/>
-	</radialGradient>
-	<radialGradient id="g" gradientUnits="userSpaceOnUse" cy="3.76" cx="8.82" gradientTransform="matrix(.968 0 0 1.033 3.35.65)" r="37.75">
-		<stop stop-color="#a3a3a3" offset="0"/>
-		<stop stop-color="#4c4c4c" offset="1"/>
-	</radialGradient>
-	<radialGradient id="e" gradientUnits="userSpaceOnUse" cy="7.27" cx="8.14" gradientTransform="matrix(.968 0 0 1.033 3.35.65)" r="38.2">
-		<stop stop-color="#fff" offset="0"/>
-		<stop stop-color="#f8f8f8" offset="1"/>
-	</radialGradient>
-	<radialGradient id="c" gradientUnits="userSpaceOnUse" cy="18.82" cx="10.1" r="1.21">
-		<stop stop-color="#f0f0f0" offset="0"/>
-		<stop stop-color="#9a9a9a" offset="1"/>
-	</radialGradient>
-</defs>
-<ellipse opacity=".8" rx="17" ry="4.5" cy="42.8" cx="24.3" fill="url(#b)"/>
-<rect rx="1.2" height="41" width="34.88" stroke="url(#g)" y="3.65" x="6.6" fill="url(#f)"/>
-<rect rx=".2" height="39" width="32.78" stroke="url(#e)" y="4.58" x="7.66" fill="none"/>
-<g fill="none">
-	<path stroke="#000" d="m11.5 5.4v37.9" stroke-opacity=".02"/>
-	<path stroke="#fff" d="m12.5 5v38" stroke-opacity=".2"/>
-</g>
-<g fill-opacity=".55" fill="#9b9b9b">
-	<g id="a">
-		<rect rx=".2" height="1" width="20" y="9" x="16"/>
-		<rect rx=".2" height="1" width="20" y="11" x="16"/>
-		<rect rx=".2" height="1" width="20" y="13" x="16"/>
-		<rect rx=".2" height="1" width="20" y="15" x="16"/>
-	</g>
-	<rect rx=".2" height="1" width="9" y="25" x="16"/>
-	<rect rx=".2" height="1" width="14" y="37" x="16"/>
-	<use y="8" xlink:href="#a"/>
-	<use y="20" xlink:href="#a"/>
-</g>
-<g id="d">
-	<circle cy="18.69" cx="10.17" r="0.82" fill="#fff"/>
-	<circle cy="18.43" cx="9.82" r="0.82" fill="url(#c)"/>
-</g>
-<use xlink:href="#d" y="11.5"/>
-</svg>

examples/webchat/htdocs/linkify-string.min.js

@@ -1 +0,0 @@
-"use strict";!function(t,r){var n=function(t){function r(t){return t.replace(/&/g,"&amp;").replace(/</g,"&lt;").replace(/>/g,"&gt;")}function n(t){return t.replace(/"/g,"&quot;")}function e(t){if(!t)return"";var r=[];for(var e in t){var i=t[e]+"";r.push(e+'="'+n(i)+'"')}return r.join(" ")}function i(t){var i=arguments.length<=1||void 0===arguments[1]?{}:arguments[1];i=new u(i);for(var a=o(t),f=[],l=0;l<a.length;l++){var s=a[l];if("nl"===s.type&&i.nl2br)f.push("<br>\n");else if(s.isLink&&i.check(s)){var c=i.resolve(s),p=c.formatted,g=c.formattedHref,v=c.tagName,h=c.className,k=c.target,y=c.attributes,m="<"+v+' href="'+n(g)+'"';h&&(m+=' class="'+n(h)+'"'),k&&(m+=' target="'+n(k)+'"'),y&&(m+=" "+e(y)),m+=">"+r(p)+"</"+v+">",f.push(m)}else f.push(r(s.toString()))}return f.join("")}var o=t.tokenize,a=t.options,u=a.Options;return String.prototype.linkify||(String.prototype.linkify=function(t){return i(this,t)}),i}(r);t.linkifyStr=n}(window,linkify);