fixups to get tests passing

Account for the case where the spec takes a step but the implementation
remains in the same state

LICENSE

@@ -0,0 +1,165 @@
+                  GNU LESSER GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+  This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+  0. Additional Definitions.
+
+  As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+  "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+  An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+  A "Combined Work" is a work produced by combining or linking an
+Application with the Library.  The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+  The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+  The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+  1. Exception to Section 3 of the GNU GPL.
+
+  You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+  2. Conveying Modified Versions.
+
+  If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+   a) under this License, provided that you make a good faith effort to
+   ensure that, in the event an Application does not supply the
+   function or data, the facility still operates, and performs
+   whatever part of its purpose remains meaningful, or
+
+   b) under the GNU GPL, with none of the additional permissions of
+   this License applicable to that copy.
+
+  3. Object Code Incorporating Material from Library Header Files.
+
+  The object code form of an Application may incorporate material from
+a header file that is part of the Library.  You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+   a) Give prominent notice with each copy of the object code that the
+   Library is used in it and that the Library and its use are
+   covered by this License.
+
+   b) Accompany the object code with a copy of the GNU GPL and this license
+   document.
+
+  4. Combined Works.
+
+  You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+   a) Give prominent notice with each copy of the Combined Work that
+   the Library is used in it and that the Library and its use are
+   covered by this License.
+
+   b) Accompany the Combined Work with a copy of the GNU GPL and this license
+   document.
+
+   c) For a Combined Work that displays copyright notices during
+   execution, include the copyright notice for the Library among
+   these notices, as well as a reference directing the user to the
+   copies of the GNU GPL and this license document.
+
+   d) Do one of the following:
+
+       0) Convey the Minimal Corresponding Source under the terms of this
+       License, and the Corresponding Application Code in a form
+       suitable for, and under terms that permit, the user to
+       recombine or relink the Application with a modified version of
+       the Linked Version to produce a modified Combined Work, in the
+       manner specified by section 6 of the GNU GPL for conveying
+       Corresponding Source.
+
+       1) Use a suitable shared library mechanism for linking with the
+       Library.  A suitable mechanism is one that (a) uses at run time
+       a copy of the Library already present on the user's computer
+       system, and (b) will operate properly with a modified version
+       of the Library that is interface-compatible with the Linked
+       Version.
+
+   e) Provide Installation Information, but only if you would otherwise
+   be required to provide such information under section 6 of the
+   GNU GPL, and only to the extent that such information is
+   necessary to install and execute a modified version of the
+   Combined Work produced by recombining or relinking the
+   Application with a modified version of the Linked Version. (If
+   you use option 4d0, the Installation Information must accompany
+   the Minimal Corresponding Source and Corresponding Application
+   Code. If you use option 4d1, you must provide the Installation
+   Information in the manner specified by section 6 of the GNU GPL
+   for conveying Corresponding Source.)
+
+  5. Combined Libraries.
+
+  You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+   a) Accompany the combined library with a copy of the same work based
+   on the Library, uncombined with any other library facilities,
+   conveyed under the terms of this License.
+
+   b) Give prominent notice with the combined library that part of it
+   is a work based on the Library, and explaining where to find the
+   accompanying uncombined form of the same work.
+
+  6. Revised Versions of the GNU Lesser General Public License.
+
+  The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+  Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+  If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.

README.md

@@ -0,0 +1,65 @@
+# 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

@@ -0,0 +1,57 @@
+digraph G {
+  node[shape=box];
+
+  // s0000 idle
+  // s1000 error
+  // s0100 supply
+  // s1100 running
+  // s1010 starting
+  // s0011 starting_unwanted
+  // s1011 starting_doomed
+  // s0101 unwanted
+  // s1101 running_doomed
+
+  idle -> starting [label="D+/start"];
+  supply -> starting [label="D+,S-/start"];
+  error -> idle [label="D-"];
+  error -> running [label="S+"];
+  error -> unwanted [label="D-,S+"];
+  running -> unwanted [label="D-"];
+  running -> error [label="S-/error"];
+
+  unwanted -> idle [label="S-"];
+  unwanted -> starting [label="D+,S-/start"];
+  running_doomed -> starting [label="S-/start"];
+  running_doomed -> idle [label="D-,S-"];
+
+  starting -> starting_unwanted [label="D-"];
+  starting -> running [label="S+"];
+  starting -> unwanted [label="D-,S+"];
+  starting_unwanted -> unwanted [label="S+"];
+  starting_unwanted -> running_doomed [label="D+,S+"];
+  starting_doomed -> running_doomed [label="S+"];
+  starting_doomed -> unwanted [label="D-,S+"];
+
+
+  idle -> supply [label="S+"];
+  idle -> running [label="D+S+"];
+  supply -> running [label="D+"];
+  supply -> idle [label="S-"];
+  running -> idle [label="D-,S-"];
+  unwanted -> running_doomed [label="D+"];
+  running_doomed -> unwanted [label="D-"];
+  starting_unwanted -> starting_doomed [label="D+"];
+  starting_doomed -> starting_unwanted [label="D-"];
+
+
+  // s0001 -> impossible [label="any"];
+  // s0010 -> impossible [label="any"];
+
+  // s1001 -> impossible [label="any"];
+
+  // s0110 -> impossible [label="any"];
+  // s1110 -> impossible [label="any"];
+  // s0111 -> impossible [label="any"];
+  // s1111 -> impossible [label="any"];
+
+}

doc/demand-matcher.md

@@ -0,0 +1,388 @@
+# Demand-matching and Supervision
+
+The Demand Matcher pattern (in `demand-matcher.rkt` and in
+`demand-matcher.js`'s `DemandMatcher` class) tracks assertions
+representing some abstract *demand* for a resource, and causes the
+creation or acquisition of matching *supply* of that resource.
+
+To do this, it tracks the state of each *instance* of the resource.
+Each resource instance (called a "task") is uniquely identified by a
+projection of the dataspace.
+
+The basic idea is that:
+
+ - When demand for a task is detected, it is started.
+
+ - Each started task signals its presence to the DemandMatcher.
+
+ - When demand drops, the task should detect this and exit.
+
+ - If the task exits unexpectedly, this is an error, and the
+   DemandMatcher prints a warning.
+
+## Latency causes problems
+
+However, because there can be some latency between requesting the
+start of a task and its signalling its presence to the DemandMatcher,
+we can't just figure out what to do based on the presence or absence
+of demand and supply for a task. We also need to track a few more bits
+of information.
+
+When demand for a task drops briefly, we expect a drop in supply in
+future, *even if demand increases again before we detect a supply
+drop*.
+
+For this reason, in some circumstances, the default task supervision
+strategy of DemandMatcher *recreates* supply on supply drop in some
+circumstances. It keeps track of whether a supply increase is
+expected, and of whether a supply decrease is expected for each task.
+
+It becomes an important part of the DemandMatcher protocol for a task
+instance to always drop its supply assertion in response to a drop in
+demand. This works well in Syndicate implementations that preserve all
+assertion transitions, but not at all well where brief transitions may
+be elided. In those cases, we will have to reach for a more heuristic
+approach involving something akin to Erlang's "Maximum Restart
+Intensity" and/or other kinds of time-based decision. For now though,
+the precise case works fine.
+
+While it seems simple enough to imagine, the details are rather
+fiddly.
+
+## Working out the algorithm that defaultTaskSupervisor should use
+
+We may assume some expected task behaviour: that it will eventually
+assert supply, and *then* upon demand drop eventually exit.
+
+    ◇(supply ∧ (¬demand ⇒ ◇ terminate))   (?!?!)
+
+### Complete table of actions
+
+Each row in this table describes actions taken in a particular
+circumstance by `defaultTaskSupervisor`.
+
+The table has seven columns:
+ - `∃D`, whether demand for the task exists currently
+ - `∃S`, whether supply for the task exists currently
+ - `ΔD`, whether (and in which direction) demand is changing now
+ - `ΔS`, whether (and in which direction) supply is changing now
+ - `expS+`, whether we expect a supply increase at some point in future
+ - `expS-`, whether we expect a supply decrease at some point in future
+ - and an action to take in this circumstance.
+
+The first two values are drawn from the state of the DemandMatcher;
+the second two, from the patch event the DemandMatcher is currently
+processing; and the third two are private state variables of the task
+supervisor itself.
+
+    ∃D ∃S  ΔD ΔS  expS+ expS-  Action
+    ---------------------------------------------------------------------------
+     -  -   +       -     -    Start task, set expS+
+     -  -      +    -     -    No action (but slightly weird)
+     -  -   +  +    -     -    No action (but slightly weird)
+     -  Y   +       -     -    No action (pre-extant supply)
+     -  Y      -    -     -    No action
+     -  Y   +  -    -     -    Start task, set expS+
+     Y  -   -       -     -    Demand goes after unexpected supply drop
+     Y  -      +    -     -    Spontaneous recovery from unexpected supply drop
+     Y  -   -  +    -     -    Spontaneous recovery from unexpected supply drop; set expS-
+     Y  Y   -       -     -    Set expS-
+     Y  Y      -    -     -    Unexpected supply drop error
+     Y  Y   -  -    -     -    No action (but slightly weird)
+
+     -  -   +       -     Y    Impossible (expS- would be clear or expS+ set)
+     -  -      +    -     Y    Impossible (expS- would be clear or expS+ set)
+     -  -   +  +    -     Y    Impossible (expS- would be clear or expS+ set)
+     -  Y   +       -     Y    No action
+     -  Y      -    -     Y    Clear expS-
+     -  Y   +  -    -     Y    Clear expS-, start task, set expS+
+     Y  -   -       -     Y    Impossible (expS+ would be set)
+     Y  -      +    -     Y    Impossible (expS+ would be set)
+     Y  -   -  +    -     Y    Impossible (expS+ would be set)
+     Y  Y   -       -     Y    No action
+     Y  Y      -    -     Y    Clear expS-, start task, set expS+
+     Y  Y   -  -    -     Y    Clear expS-
+
+     -  -   +       Y     -    Impossible (expS+ would be clear or expS- set)
+     -  -      +    Y     -    Impossible (expS+ would be clear or expS- set)
+     -  -   +  +    Y     -    Impossible (expS+ would be clear or expS- set)
+     -  Y   +       Y     -    Impossible (expS+ would be clear)
+     -  Y      -    Y     -    Impossible (expS+ would be clear)
+     -  Y   +  -    Y     -    Impossible (expS+ would be clear)
+     Y  -   -       Y     -    Set expS-
+     Y  -      +    Y     -    Clear expS+
+     Y  -   -  +    Y     -    Clear expS+, set expS-
+     Y  Y   -       Y     -    Impossible (expS+ would be clear)
+     Y  Y      -    Y     -    Impossible (expS+ would be clear)
+     Y  Y   -  -    Y     -    Impossible (expS+ would be clear)
+
+     -  -   +       Y     Y    No action
+     -  -      +    Y     Y    Clear expS+
+     -  -   +  +    Y     Y    Clear expS+
+     -  Y   +       Y     Y    Impossible (expS+ would be clear)
+     -  Y      -    Y     Y    Impossible (expS+ would be clear)
+     -  Y   +  -    Y     Y    Impossible (expS+ would be clear)
+     Y  -   -       Y     Y    No action
+     Y  -      +    Y     Y    Clear expS+
+     Y  -   -  +    Y     Y    Clear expS+
+     Y  Y   -       Y     Y    Impossible (expS+ would be clear)
+     Y  Y      -    Y     Y    Impossible (expS+ would be clear)
+     Y  Y   -  -    Y     Y    Impossible (expS+ would be clear)
+
+#### Actions and transitions involving actions
+
+From the table, we learn that the possible actions are:
+
+ - `START`, Start task, set expS+
+ - `EXPDROP`, Set expS-
+ - `GOTDROP`, Clear expS-
+ - `RUNNING`, Clear expS+
+
+There are also a couple of pseudo-actions, `ERROR` for an unexpected
+supply drop, and `RECOVER` for circumstances marking spontaneous
+recovery after an unexpected supply drop.
+
+The final four columns in this table are the new states of the
+DemandMatcher and the task supervisor.
+
+    ∃D ∃S  ΔD ΔS  expS+ expS-  Actions         Next: ∃D ∃S  expS+ expS-
+    ---------------------------------------------------------------------------
+     -  -   +       -     -    START                  Y  -    Y     -
+     -  Y   +  -    -     -    START                  Y  -    Y     -
+     Y  -   -       -     -    RECOVERY               -  -    -     -
+     Y  -      +    -     -    RECOVER                Y  Y    -     -
+     Y  -   -  +    -     -    RECOVER EXPDROP        -  Y    -     Y
+     Y  Y   -       -     -    EXPDROP                -  Y    -     Y
+     Y  Y      -    -     -    ERROR                  Y  -    -     -
+
+     -  Y      -    -     Y    GOTDROP                -  -    -     -
+     -  Y   +  -    -     Y    GOTDROP START          Y  -    Y     -
+     Y  Y      -    -     Y    GOTDROP START          Y  -    Y     -
+     Y  Y   -  -    -     Y    GOTDROP                -  -    -     -
+
+     Y  -   -       Y     -    EXPDROP                -  -    Y     Y
+     Y  -      +    Y     -    RUNNING                Y  Y    -     -
+     Y  -   -  +    Y     -    RUNNING EXPDROP        -  Y    -     Y
+
+     -  -      +    Y     Y    RUNNING                -  Y    -     Y
+     -  -   +  +    Y     Y    RUNNING                Y  Y    -     Y
+     Y  -      +    Y     Y    RUNNING                Y  Y    -     Y
+     Y  -   -  +    Y     Y    RUNNING                -  Y    -     Y
+
+#### Impossible states
+
+Some states are impossible to reach.
+
+It is impossible for neither supply nor demand to exist, when either
+but not both of a rise or a drop in supply is expected:
+
+    ∃D ∃S  ΔD ΔS  expS+ expS-
+    ---------------------------------------------------------------------------
+     -  -           -     Y    Impossible (expS- would be clear or expS+ set)
+     -  -           Y     -    Impossible (expS+ would be clear or expS- set)
+
+It is impossible for demand but no supply to exist, when a drop in
+supply is expected but no rise in supply is expected:
+
+    ∃D ∃S  ΔD ΔS  expS+ expS-
+    ---------------------------------------------------------------------------
+     Y  -           -     Y    Impossible (expS+ would be set)
+
+It is impossible for supply to exist while a rise in supply is
+expected:
+
+    ∃D ∃S  ΔD ΔS  expS+ expS-
+    ---------------------------------------------------------------------------
+     -  Y           Y     -    Impossible (expS+ would be clear)
+     Y  Y           Y     -    Impossible (expS+ would be clear)
+     -  Y           Y     Y    Impossible (expS+ would be clear)
+     Y  Y           Y     Y    Impossible (expS+ would be clear)
+
+#### Transitions involving only DemandMatcher state change
+
+Where no task supervisor state changes and no actions are needed:
+
+    ∃D ∃S  ΔD ΔS  expS+ expS-  Actions         Next: ∃D ∃S  expS+ expS-
+    ---------------------------------------------------------------------------
+     -  -      +    -     -                           -  Y    -     -
+     -  -   +  +    -     -                           Y  Y    -     -
+     -  Y   +       -     -                           Y  Y    -     -
+     -  Y      -    -     -                           -  -    -     -
+     Y  Y   -  -    -     -                           -  -    -     -
+     -  Y   +       -     Y                           Y  Y    -     Y
+     Y  Y   -       -     Y                           -  Y    -     Y
+     -  -   +       Y     Y                           Y  -    Y     Y
+     Y  -   -       Y     Y                           -  -    Y     Y
+
+### Transition diagram
+
+![DemandMatcher task supervisor transition diagram](demand-matcher.png)
+
+### From state machine to implementation
+
+We can give the reachable states reasonable names:
+
+    ∃D ∃S  expS+ expS-  Name
+    ---------------------------------------
+     -  -    -     -    IDLE
+     Y  -    Y     -    STARTING
+     Y  Y    -     -    RUNNING
+     -  Y    -     Y    UNWANTED
+
+     Y  -    Y     Y    STARTING_DOOMED
+     -  -    Y     Y    STARTING_UNWANTED
+     Y  Y    -     Y    RUNNING_DOOMED
+
+     -  Y    -     -    SUPPLY
+     Y  -    -     -    ERROR
+
+However, writing out the full state machine in terms of these states
+doesn't exploit all the redundancy in the machine.
+
+Instead, let's group transitions by their effects on the task
+supervisor's state, the "expected" bits. There are only four possible
+actions (excluding warnings related to recovery etc.):
+
+    START   - set expS+ (and start a task instance)
+    RUNNING - clear expS+
+    EXPDROP - set expS-
+    GOTDROP - clear expS-
+
+---------------------------------------------------------------------------
+
+Leave expS+ alone, set expS-:
+
+     Y  -   -  +    -     -                  EXPDROP           -  Y    -     Y
+     Y  Y   -       -     -                  EXPDROP           -  Y    -     Y
+     Y  -   -       Y     -                  EXPDROP           -  -    Y     Y
+
+Leave expS+ alone, clear expS-:
+
+     -  Y      -    -     Y                          GOTDROP   -  -    -     -
+     Y  Y   -  -    -     Y                          GOTDROP   -  -    -     -
+
+Set expS+, leave expS- alone:
+
+     -  -   +       -     -    START                           Y  -    Y     -
+     -  Y   +  -    -     -    START                           Y  -    Y     -
+
+Set expS+, clear expS-:
+
+     -  Y   +  -    -     Y    START                 GOTDROP   Y  -    Y     -
+     Y  Y      -    -     Y    START                 GOTDROP   Y  -    Y     -
+
+Clear expS+, leave expS- alone:
+
+     Y  -      +    Y     -          RUNNING                   Y  Y    -     -
+     -  -      +    Y     Y          RUNNING                   -  Y    -     Y
+     -  -   +  +    Y     Y          RUNNING                   Y  Y    -     Y
+     Y  -      +    Y     Y          RUNNING                   Y  Y    -     Y
+     Y  -   -  +    Y     Y          RUNNING                   -  Y    -     Y
+
+Clear expS+, set expS-:
+
+     Y  -   -  +    Y     -          RUNNING EXPDROP           -  Y    -     Y
+
+---------------------------------------------------------------------------
+
+Now, let's look at those grouped by specific action (some rows will
+appear twice, because some rows involve more than one action):
+
+Expdrop:
+
+     Y  -   -  +    -     -                  EXPDROP           -  Y    -     Y
+     Y  Y   -       -     -                  EXPDROP           -  Y    -     Y
+     Y  -   -       Y     -                  EXPDROP           -  -    Y     Y
+     Y  -   -  +    Y     -          RUNNING EXPDROP           -  Y    -     Y
+
+ - "Set expS- whenever a drop in demand is detected, and either (a)
+   increase in supply is detected, (b) supply exists and is not
+   falling, or (c) supply is expected to exist."
+
+Gotdrop:
+
+     -  Y      -    -     Y                          GOTDROP   -  -    -     -
+     Y  Y   -  -    -     Y                          GOTDROP   -  -    -     -
+     -  Y   +  -    -     Y    START                 GOTDROP   Y  -    Y     -
+     Y  Y      -    -     Y    START                 GOTDROP   Y  -    Y     -
+
+ - "Clear expS- whenever a drop in supply is detected."
+
+Start:
+
+     -  -   +       -     -    START                           Y  -    Y     -
+     -  Y   +  -    -     -    START                           Y  -    Y     -
+     -  Y   +  -    -     Y    START                 GOTDROP   Y  -    Y     -
+     Y  Y      -    -     Y    START                 GOTDROP   Y  -    Y     -
+
+ - "Set expS+ and start a task whenever expS+ is clear and demand
+   becomes or remains high and supply becomes or remains low UNLESS
+   demand is already high, supply drops, and expS- is clear, which is
+   the 'unexpected drop' error case."
+
+Running:
+
+     Y  -      +    Y     -          RUNNING                   Y  Y    -     -
+     -  -      +    Y     Y          RUNNING                   -  Y    -     Y
+     -  -   +  +    Y     Y          RUNNING                   Y  Y    -     Y
+     Y  -      +    Y     Y          RUNNING                   Y  Y    -     Y
+     Y  -   -  +    Y     Y          RUNNING                   -  Y    -     Y
+     Y  -   -  +    Y     -          RUNNING EXPDROP           -  Y    -     Y
+
+ - "Clear expS+ whenever supply increases."
+
+---------------------------------------------------------------------------
+
+Now let's take those rules and check them against the full rulebase:
+
+"Set expS- whenever a drop in demand is detected, and either (a)
+increase in supply is detected, (b) supply exists and is not
+falling, or (c) supply is expected to exist."
+
+     Y  -   -  +    -     -    RECOVER EXPDROP        -  Y    -     Y
+     Y  Y   -       -     -    EXPDROP                -  Y    -     Y
+     Y  -   -       Y     -    EXPDROP                -  -    Y     Y
+     Y  -   -  +    Y     -    RUNNING EXPDROP        -  Y    -     Y
+     Y  -   -  +    Y     Y    RUNNING                -  Y    -     Y
+     Y  Y   -       -     Y                           -  Y    -     Y
+     Y  -   -       Y     Y                           -  -    Y     Y
+
+"Clear expS- whenever a drop in supply is detected."
+
+     -  Y   +  -    -     -    START                  Y  -    Y     -
+     Y  Y      -    -     -    ERROR                  Y  -    -     -
+     -  Y      -    -     Y    GOTDROP                -  -    -     -
+     -  Y   +  -    -     Y    GOTDROP START          Y  -    Y     -
+     Y  Y      -    -     Y    GOTDROP START          Y  -    Y     -
+     Y  Y   -  -    -     Y    GOTDROP                -  -    -     -
+     -  Y      -    -     -                           -  -    -     -
+     Y  Y   -  -    -     -                           -  -    -     -
+
+"Set expS+ and start a task whenever expS+ is clear and demand
+becomes or remains high and supply becomes or remains low UNLESS
+demand is already high, supply drops, and expS- is clear, which is
+the 'unexpected drop' error case."
+
+     -  -   +       -     -    START                  Y  -    Y     -
+     -  Y   +  -    -     -    START                  Y  -    Y     -
+     Y  Y      -    -     -    ERROR                  Y  -    -     -
+     -  Y   +  -    -     Y    GOTDROP START          Y  -    Y     -
+     Y  Y      -    -     Y    GOTDROP START          Y  -    Y     -
+
+"Clear expS+ whenever supply increases."
+
+     Y  -      +    -     -    RECOVER                Y  Y    -     -
+     Y  -   -  +    -     -    RECOVER EXPDROP        -  Y    -     Y
+     Y  -      +    Y     -    RUNNING                Y  Y    -     -
+     Y  -   -  +    Y     -    RUNNING EXPDROP        -  Y    -     Y
+     -  -      +    Y     Y    RUNNING                -  Y    -     Y
+     -  -   +  +    Y     Y    RUNNING                Y  Y    -     Y
+     Y  -      +    Y     Y    RUNNING                Y  Y    -     Y
+     Y  -   -  +    Y     Y    RUNNING                -  Y    -     Y
+     -  -      +    -     -                           -  Y    -     -
+     -  -   +  +    -     -                           Y  Y    -     -
+
+By looking at the next-state columns corresponding to the action
+described, we can see that each predicate used to decide whether to
+set or clear each state bit is a sound overapproximation of the
+behaviour we want.

examples/ircd/.gitignore

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

examples/ircd/Makefile

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

examples/ircd/TODO.md

@@ -0,0 +1,17 @@
+Try changing the motd and saving the file. It'll reload. The log
+messages suggest that the server is dropping extant connection - as
+expected - but it immediately comes back momentarily before going away
+properly. The session is able to reboot due to the glitching in
+assertion of the listen port *more quickly* than the latency of
+teardown of the previous connection; so the new session-listener
+responds to the assertions from the old connection before the old
+connection has a chance to die. Of course, it *does* die (since commit
+11de40c), but having that zombie reborn new session is annoying.
+
+ - This is thorny. You'd think that having a session wait for its
+   line-reader to go would be enough, but the multiple nested
+   during/spawns creating the sessions mean that no matter how long
+   the old session instance sticks around, a new session will appear
+   before we're ready! ... maybe there's no way *at all* to
+   disambiguate old/new instances without, say, a unique
+   listener-socket identifier??

examples/ircd/channel.rkt

@@ -0,0 +1,24 @@
+#lang syndicate
+
+(require "protocol.rkt")
+(require "message.rkt")
+
+(require/activate syndicate/reload)
+
+(spawn #:name 'channel-factory
+       (stop-when-reloaded)
+       (during/spawn (ircd-channel-member $Ch _)
+         #:name `(ircd-channel ,Ch)
+         (field [topic #f])
+         (assert (ircd-channel-topic Ch (topic)))
+
+         (on (message (ircd-action $who (irc-message _ "MODE" (list Ch "b") _)))
+             (send! (ircd-event who (irc-message server-prefix 368 (list (lookup-nick who) Ch)
+                                                 "End of Channel Ban List"))))
+
+         (on (message (ircd-action $who (irc-message _ "MODE" (list Ch) _)))
+             (send! (ircd-event who (irc-message server-prefix 324
+                                                 (list (lookup-nick who) Ch "+") #f))))
+
+         (on (message (ircd-action _ (irc-message _ "TOPIC" (list Ch) $new-topic)))
+             (topic new-topic))))

examples/ircd/config.rkt

@@ -0,0 +1,14 @@
+#lang syndicate
+
+(require/activate syndicate/reload)
+(require/activate syndicate/supervise)
+(require/activate syndicate/drivers/config)
+
+(require "protocol.rkt")
+
+(spawn #:name 'config
+       (stop-when-reloaded)
+
+       (assert (ircd-motd (list "Hello, world!")))
+
+       (assert (ircd-listener 6667)))

examples/ircd/main.rkt

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

examples/ircd/message.rkt

@@ -0,0 +1,93 @@
+#lang racket/base
+
+(provide (struct-out irc-message)
+         (struct-out irc-user)
+         (struct-out irc-privmsg)
+
+         (struct-out irc-source-servername)
+         (struct-out irc-source-nick)
+
+         parse-irc-message
+         render-irc-message
+
+         ;; TODO make these assertions in the dataspace:
+         server-name
+         server-prefix)
+
+(require racket/string)
+(require racket/match)
+(require racket/format)
+
+;; <message>  ::= [':' <prefix> <SPACE> ] <command> <params> <crlf>
+;; <prefix>   ::= <servername> | <nick> [ '!' <user> ] [ '@' <host> ]
+;; <command>  ::= <letter> { <letter> } | <number> <number> <number>
+;; <SPACE>    ::= ' ' { ' ' }
+;; <params>   ::= <SPACE> [ ':' <trailing> | <middle> <params> ]
+;;
+;; <middle>   ::= <Any *non-empty* sequence of octets not including SPACE
+;;                or NUL or CR or LF, the first of which may not be ':'>
+;; <trailing> ::= <Any, possibly *empty*, sequence of octets not including
+;;                  NUL or CR or LF>
+;;
+;; <crlf>     ::= CR LF
+
+;; <target>     ::= <to> [ "," <target> ]
+;; <to>         ::= <channel> | <user> '@' <servername> | <nick> | <mask>
+;; <channel>    ::= ('#' | '&') <chstring>
+;; <servername> ::= <host>
+;; <host>       ::= see RFC 952 [DNS:4] for details on allowed hostnames
+;; <nick>       ::= <letter> { <letter> | <number> | <special> }
+;; <mask>       ::= ('#' | '$') <chstring>
+;; <chstring>   ::= <any 8bit code except SPACE, BELL, NUL, CR, LF and
+;;                   comma (',')>
+
+;; <user>       ::= <nonwhite> { <nonwhite> }
+;; <letter>     ::= 'a' ... 'z' | 'A' ... 'Z'
+;; <number>     ::= '0' ... '9'
+;; <special>    ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'
+
+;; <nonwhite>   ::= <any 8bit code except SPACE (0x20), NUL (0x0), CR
+;;                   (0xd), and LF (0xa)>
+
+(struct irc-message (prefix command params trailing) #:prefab)
+(struct irc-user (username hostname realname) #:prefab)
+(struct irc-privmsg (source target text) #:prefab)
+
+(struct irc-source-servername (servername) #:prefab)
+(struct irc-source-nick (nick user) #:prefab)
+
+(define (parse-irc-message line0)
+  (match (string-trim #:left? #f line0 #px"[\r\n]")
+    [(pregexp #px"^:([^ ]+) +(.*)$" (list _ prefix rest)) (parse-command prefix rest)]
+    [line (parse-command #f line)]))
+
+(define (parse-command prefix line)
+  (match-define (pregexp #px"^([^ ]+)( +([^:]+)?(:(.*))?)?$" (list _ command _ params _ rest)) line)
+  (irc-message prefix
+               (string-upcase command)
+               (string-split (or params ""))
+               rest))
+
+;; libpurple's irc protocol support crashes (!) (SIGSEGV) if you send
+;; a prefix on a JOIN event from the server as just "nick" rather than
+;; "nick!user@host" - specifically, it will crash if "!" doesn't
+;; appear in the prefix.
+;;
+(define (render-irc-message m)
+  (match-define (irc-message prefix command params trailing) m)
+  (string-append (render-prefix prefix)
+                 (~a command)
+                 (if (pair? params) (string-append " " (string-join (map ~a params))) "")
+                 (if trailing (string-append " :" trailing) "")))
+
+(define (render-prefix p)
+  (match p
+    [#f
+     ""]
+    [(irc-source-servername servername)
+     (format ":~a " servername)]
+    [(irc-source-nick nick (irc-user username hostname _))
+     (format ":~a!~a@~a " nick username hostname)]))
+
+(define server-name "syndicate-ircd")
+(define server-prefix (irc-source-servername "syndicate-ircd.example"))

examples/ircd/protocol.rkt

@@ -0,0 +1,30 @@
+#lang syndicate
+
+(provide (struct-out ircd-listener)
+         (struct-out ircd-motd)
+
+         (struct-out ircd-connection-info)
+         (struct-out ircd-channel-member)
+         (struct-out ircd-channel-topic)
+
+         (struct-out ircd-action)
+         (struct-out ircd-event)
+
+         lookup-nick)
+
+;; A Connection is a TcpAddress
+
+(struct ircd-listener (port) #:prefab) ;; assertion
+(struct ircd-motd (lines) #:prefab) ;; assertion
+
+(struct ircd-connection-info (conn nick user) #:prefab) ;;assertion
+(struct ircd-channel-member (channel conn) #:prefab) ;; assertion
+(struct ircd-channel-topic (channel topic) #:prefab) ;; assertion
+
+(struct ircd-action (conn message) #:prefab) ;; message
+(struct ircd-event (conn message) #:prefab) ;; message
+
+;;---------------------------------------------------------------------------
+
+(define (lookup-nick conn)
+  (immediate-query [query-value #f (ircd-connection-info conn $N _) N]))

examples/ircd/session.rkt

@@ -0,0 +1,177 @@
+#lang syndicate
+
+(require racket/set)
+(require racket/string)
+
+(require "protocol.rkt")
+(require "message.rkt")
+
+(require/activate syndicate/reload)
+(require/activate syndicate/drivers/tcp)
+(require/activate syndicate/drivers/line-reader)
+(require syndicate/protocol/advertise)
+(require syndicate/support/hash)
+
+(define (ircd-connection-facet this-conn server-handle)
+  (define (send-to-remote #:newline [with-newline #t] fmt . vs)
+    (define bs (string->bytes/utf-8 (apply format fmt vs)))
+    (log-info "~a <- ~v" this-conn bs)
+    (send! (tcp-channel server-handle this-conn (if with-newline (bytes-append bs #"\r\n") bs))))
+
+  (define (send-irc-message m)
+    (send-to-remote "~a" (render-irc-message m)))
+
+  (define (send* #:source [prefix server-prefix] #:trailing [trailing #f] command . params)
+    (send-irc-message (irc-message prefix command params trailing)))
+
+  (on-start (log-info "Connecting ~a" this-conn))
+  (on-stop (log-info "Disconnecting ~a" this-conn))
+
+  (field [nick #f]
+         [user #f])
+  (define/dataflow conn-info (ircd-connection-info this-conn (nick) (user)))
+  (assert (conn-info))
+
+  (on-start
+   (react
+    (stop-when (asserted (ircd-motd $motd-lines))
+      (react
+       (begin/dataflow
+         (when (and (nick) (user))
+           (send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name))
+           (for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line)))
+           (send* 376 (nick) #:trailing (format "End of /MOTD command"))
+           (stop-current-facet)))))))
+
+  (field [peer-common-channels (hash)]
+         [peer-names (hash)])
+
+  (during (ircd-channel-member $Ch this-conn)
+    (field [initial-names-sent? #f]
+           [initial-member-nicks (set)])
+
+    (on-start (send* #:source (irc-source-nick (nick) (user)) "JOIN" Ch)
+              (flush!)
+              (flush!)
+              (define nicks (initial-member-nicks))
+              (initial-names-sent? #t)
+              (initial-member-nicks 'no-longer-valid)
+              (send* 353 (nick) "@" Ch #:trailing (string-join (set->list nicks)))
+              (send* 366 (nick) Ch #:trailing "End of /NAMES list"))
+
+    (during (ircd-channel-member Ch $other-conn)
+      (on-start (peer-common-channels (hashset-add (peer-common-channels) other-conn Ch)))
+      (on-stop (peer-common-channels (hashset-remove (peer-common-channels) other-conn Ch)))
+      (field [current-other-source #f])
+      (define/query-value next-other-source #f
+        (ircd-connection-info other-conn $N $U)
+        (irc-source-nick N U))
+      (on (retracted (ircd-channel-member Ch other-conn))
+          (when (current-other-source) (send* #:source (current-other-source) "PART" Ch)))
+      (on-stop (when (not (hash-has-key? (peer-common-channels) other-conn))
+                 (peer-names (hash-remove (peer-names) other-conn))))
+      (begin/dataflow
+        (when (not (equal? (current-other-source) (next-other-source)))
+          (if (not (next-other-source)) ;; other-conn is disconnecting
+              (when (hash-ref (peer-names) other-conn #f)
+                (send* #:source (current-other-source) "QUIT")
+                (peer-names (hash-remove (peer-names) other-conn)))
+              (begin
+                (cond
+                  [(not (initial-names-sent?)) ;; still gathering data for 353/366 below
+                   (initial-member-nicks (set-add (initial-member-nicks)
+                                                  (irc-source-nick-nick (next-other-source))))]
+                  [(not (current-other-source)) ;; other-conn is joining
+                   (send* #:source (next-other-source) "JOIN" Ch)]
+                  [else ;; it's a nick change
+                   (when (not (equal? this-conn other-conn)) ;; avoid dups for our own connection
+                     (when (not (equal? (next-other-source) (hash-ref (peer-names) other-conn #f)))
+                       (send* #:source (current-other-source) "NICK"
+                              (irc-source-nick-nick (next-other-source)))))])
+                (peer-names (hash-set (peer-names) other-conn (next-other-source)))))
+          (current-other-source (next-other-source)))))
+
+    (on (asserted (ircd-channel-topic Ch $topic))
+        (if topic
+            (send* 332 (nick) Ch #:trailing topic)
+            (send* 331 (nick) Ch #:trailing "No topic is set")))
+
+    (on (message (ircd-action this-conn (irc-message _ "WHO" (list Ch) _)))
+        (flush!) ;; Wait for responses to come in. GROSS and not in
+                 ;; general correct (e.g. in the presence of
+                 ;; pipelining)
+        (send! (ircd-event this-conn
+                           (irc-message server-prefix 315 (list (nick) Ch) "End of WHO list."))))
+    (on (message (ircd-action $who (irc-message _ "WHO" (list Ch) _)))
+        (match-define (irc-user U H R) (user))
+        (send! (ircd-event who (irc-message server-prefix 352
+                                            (list (nick) Ch U H server-name (nick) "H")
+                                            (format "0 ~a" R)))))
+
+    (on (message (ircd-action $other-conn (irc-privmsg $source Ch $text)))
+        (when (not (equal? other-conn this-conn))
+          (send* #:source source "PRIVMSG" Ch #:trailing text))))
+
+  (on (message (ircd-event this-conn $m))
+      (send-irc-message m))
+
+  (on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text)))
+      (when (not (equal? other-conn this-conn))
+        (send* #:source source "PRIVMSG" (nick) #:trailing text)))
+
+  (on (message (tcp-channel-line this-conn server-handle $bs))
+      (define m (parse-irc-message (bytes->string/utf-8 bs)))
+      (log-info "~a -> ~v" this-conn m)
+      (send! (ircd-action this-conn m))
+      (match m
+        [(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs
+        [(or (irc-message _ "NICK" (list N) _)
+             (irc-message _ "NICK" '() N)) ;; libpurple does this (!)
+         ;; TODO: enforce syntactic restrictions on nick
+         (if (immediate-query [query-value #f (ircd-connection-info _ N _) #t])
+             (send* 433 N #:trailing "Nickname is already in use")
+             (begin (when (nick) (send* #:source (irc-source-nick (nick) (user)) "NICK" N))
+                    (nick N)))]
+        [(irc-message _ "USER" (list U _Hostname _Servername) R)
+         ;; TODO: enforce syntactic restrictions on parameters to USER
+         (define H (tcp-address-host this-conn))
+         (user (irc-user U H R))]
+        [(irc-message _ "QUIT" _ _) (stop-current-facet)]
+        [_
+         (when (and (nick) (user))
+           (match m
+             [(irc-message _ "JOIN" (cons Channels _MaybeKeys) _)
+              (for [(Ch (string-split Channels #px",+"))]
+                (assert! (ircd-channel-member Ch this-conn)))]
+             [(irc-message _ "PART" (list Channels) _)
+              (for [(Ch (string-split Channels #px",+"))]
+                (retract! (ircd-channel-member Ch this-conn)))]
+             [(irc-message _ "WHOIS" _ _)
+              (send* 318 (nick) #:trailing "End of /WHOIS list")] ;; TODO
+             [(irc-message _ "PRIVMSG" (list Targets) Text)
+              (for [(T (string-split Targets #px",+"))]
+                (send! (ircd-action this-conn
+                                    (irc-privmsg (irc-source-nick (nick) (user)) T Text))))]
+             [_ (void)]))])))
+
+(spawn #:name 'ison-responder
+       (stop-when-reloaded)
+       (define/query-set nicks (ircd-connection-info _ $N _) N)
+       (on (message (ircd-action $conn (irc-message _ "ISON" $SomeNicks $MoreNicks)))
+           (define Nicks (append SomeNicks (string-split (or MoreNicks ""))))
+           (define (on? N) (set-member? (nicks) N))
+           (define Present (string-join (filter on? Nicks) " "))
+           (send! (ircd-event conn (irc-message server-prefix 303 '("*") Present)))))
+
+(spawn #:name 'session-listener-factory
+       (stop-when-reloaded)
+       (during/spawn (ircd-listener $port)
+         #:name (ircd-listener port)
+         (on-start (log-info "Listening on port ~a." port))
+         (on-stop (log-info "No longer listening on port ~a." port))
+         (define server-handle (tcp-listener port))
+         (assert (advertise (observe (tcp-channel _ server-handle _))))
+         (during/spawn (advertise (tcp-channel $this-conn server-handle _))
+           #:name `(ircd-connection ,this-conn ,server-handle)
+           (assert (advertise (tcp-channel server-handle this-conn _)))
+           (ircd-connection-facet this-conn server-handle))))

examples/netstack/README.md

@@ -0,0 +1,29 @@
+# TCP/IP Stack
+
+There are two (closely-related) implementations here:
+
+ - [`monolithic-lowlevel`](monolithic-lowlevel/) is the original
+   implementation, originally written for `minimart`, a language that
+   followed our ESOP 2014 paper quite closely. Porting it to a
+   monolithic-assertion-set Syndicate dialect helped substantially
+   simplify the code.
+
+ - [`incremental-highlevel`](incremental-highlevel/) is a port of
+   `monolithic-lowlevel` to the Syndicate high-level DSL
+   ("`syndicate/actor`"). Moving from the low-level Syndicate style to
+   the high-level style also drastically simplified the code.
+
+## Linux Firewall Configuration
+
+Imagine a setup where the machine you are running this code has IP
+192.168.1.10. This code claims 192.168.1.222 for itself. Now, pinging
+192.168.1.222 from some other machine, say 192.168.1.99, will cause
+the local kernel to receive the pings and then *forward them on to
+192.168.1.222*, which because of the gratuitous ARP announcement, it
+knows to be on its own Ethernet MAC address. This causes the ping
+requests to repeat endlessly, each time with one lower TTL.
+
+One approach to solving the problem is to prevent the kernel from
+forwarding packets addressed to 192.168.1.222. To do this,
+
+    sudo iptables -I FORWARD -d 192.168.1.222 -j DROP

examples/netstack/TODO.md

@@ -0,0 +1,24 @@
+Ideas on TCP unit testing:
+<https://www.snellman.net/blog/archive/2015-07-09-unit-testing-a-tcp-stack/>
+
+Check behaviour around TCP zero-window probing. Is the correct
+behaviour already a consequence of the way `send-outbound` works?
+
+Do something smarter with TCP timers and RTT estimation than the
+nothing that's already being done.
+
+TCP options negotiation.
+ - SACK
+ - Window scaling
+
+Check that we handle the situations in figs. 9, 10, 11, pp.33- of RFC 793.
+
+Bugs:
+ - RST kills a connection even if its sequence number is bogus. Check
+   to make sure it's in the window. (See
+   http://static.googleusercontent.com/media/research.google.com/en//pubs/archive/41848.pdf
+   and RFC 5961)
+
+   Conform better to the rules for reset generation and processing
+   from pp.36- of RFC 793. In particular, do not blindly accept RSTs
+   without checking sequence numbers against windows etc.

examples/netstack/incremental-highlevel/Makefile

@@ -0,0 +1,12 @@
+all:
+
+run:
+	raco make main.rkt && racket main.rkt
+
+clean:
+	find . -name compiled -type d | xargs rm -rf
+	rm -f cpingresp
+
+cpingresp: cpingresp.c
+	$(CC) -o $@ $<
+	sudo setcap cap_net_raw+p+i+e $@

examples/netstack/incremental-highlevel/arp.rkt

@@ -0,0 +1,196 @@
+#lang syndicate
+;; ARP protocol, http://tools.ietf.org/html/rfc826
+;; Only does ARP-over-ethernet.
+
+(provide (struct-out arp-query)
+	 (struct-out arp-assertion)
+	 (struct-out arp-interface)
+         spawn-arp-driver)
+
+(require racket/set)
+(require racket/match)
+(require/activate syndicate/drivers/timer)
+(require bitsyntax)
+
+(require "dump-bytes.rkt")
+(require "configuration.rkt")
+(require/activate "ethernet.rkt")
+
+(struct arp-query (protocol protocol-address interface link-address) #:prefab)
+(struct arp-assertion (protocol protocol-address interface-name) #:prefab)
+(struct arp-interface (interface-name) #:prefab)
+
+(struct arp-interface-up (interface-name) #:prefab)
+
+(define ARP-ethertype #x0806)
+(define cache-entry-lifetime-msec (* 14400 1000))
+(define wakeup-interval 5000)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (spawn-arp-driver)
+  (spawn #:name 'arp-driver
+         (during/spawn (arp-interface $interface-name)
+                       #:name (list 'arp-interface interface-name)
+                       (assert (arp-interface-up interface-name))
+                       (on-start (define hwaddr (lookup-ethernet-hwaddr interface-name))
+                                 (when (not hwaddr)
+                                   (error 'arp "Failed to look up ARP interface ~v"
+                                          interface-name))
+                                 (react (run-arp-interface interface-name hwaddr))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(struct cache-key (protocol address) #:transparent)
+(struct cache-value (expiry interface address) #:transparent)
+
+(define (expire-cache c)
+  (define now (current-inexact-milliseconds))
+  (define (not-expired? v) (< now (cache-value-expiry v)))
+  (for/hash [((k v) (in-hash c)) #:when (not-expired? v)]
+    (values k v)))
+
+(define (run-arp-interface interface-name hwaddr)
+  (log-info "ARP interface ~v ~v" interface-name hwaddr)
+  (define interface (ethernet-interface interface-name hwaddr))
+
+  (define (build-packet dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
+    (define hlen (bytes-length target-ha))
+    (define plen (bytes-length target-pa))
+    (define packet (bit-string->bytes
+		    (bit-string (1 :: integer bytes 2)
+				(ptype :: integer bytes 2)
+				hlen
+				plen
+				(oper :: integer bytes 2)
+				(sender-ha :: binary bytes hlen)
+				(sender-pa :: binary bytes plen)
+				(target-ha :: binary bytes hlen)
+				(target-pa :: binary bytes plen))))
+    (ethernet-packet interface
+		     #f
+		     hwaddr
+		     dest-mac
+		     ARP-ethertype
+		     packet))
+
+  (define (some-asserted-pa ptype)
+    (match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (set->list (assertions)))
+      ['() #f]
+      [(list* k _) (cache-key-address k)]))
+
+  (define (send-questions!)
+    (for [(q (set-subtract (queries) (list->set (hash-keys (cache)))))]
+      (define pa (some-asserted-pa (cache-key-protocol q)))
+      (log-info "~a ARP Asking for ~a from ~a"
+                interface-name
+                (pretty-bytes (cache-key-address q))
+                (and pa (pretty-bytes pa)))
+      (when pa
+        (send! (build-packet broadcast-ethernet-address
+                             (cache-key-protocol q)
+                             1 ;; request
+                             hwaddr
+                             pa
+                             zero-ethernet-address
+                             (cache-key-address q))))))
+
+  (field [cache (hash)]
+         [queries (set)]
+         [assertions (set)])
+
+  (on-start (define timer-key (list 'arp interface-name))
+            (define (arm-timer!) (send! (set-timer timer-key wakeup-interval 'relative)))
+            (arm-timer!)
+            (react (on (message (timer-expired timer-key _))
+                       (cache (expire-cache (cache)))
+                       (send-questions!)
+                       (arm-timer!))))
+
+  (on (message ($ p (ethernet-packet-pattern interface-name #t ARP-ethertype)))
+      (match-define (ethernet-packet _ _ source destination _ body) p)
+      (bit-string-case body
+         ([ (= 1 :: integer bytes 2)
+            (ptype :: integer bytes 2)
+            hlen
+            plen
+            (oper :: integer bytes 2)
+            (sender-hardware-address0 :: binary bytes hlen)
+            (sender-protocol-address0 :: binary bytes plen)
+            (target-hardware-address0 :: binary bytes hlen)
+            (target-protocol-address0 :: binary bytes plen)
+            (:: binary) ;; The extra zeros exist because ethernet packets
+                        ;; have a minimum size. This is, in part, why IPv4
+                        ;; headers have a total-length field, so that the
+                        ;; zero padding can be removed.
+            ]
+          (let ()
+            (define sender-protocol-address (bit-string->bytes sender-protocol-address0))
+            (define sender-hardware-address (bit-string->bytes sender-hardware-address0))
+            (define target-protocol-address (bit-string->bytes target-protocol-address0))
+            (define learned-key (cache-key ptype sender-protocol-address))
+
+            (when (and (set-member? (queries) learned-key) ;; it is relevant to our interests
+                       (not (equal? sender-hardware-address
+                                    (cache-value-address (hash-ref (cache)
+                                                                   learned-key
+                                                                   (lambda ()
+                                                                     (cache-value #f #f #f)))))))
+              (log-info "~a ARP Adding ~a = ~a to cache"
+                        interface-name
+                        (pretty-bytes sender-protocol-address)
+                        (pretty-bytes sender-hardware-address)))
+
+            (cache (hash-set (expire-cache (cache))
+                             learned-key
+                             (cache-value (+ (current-inexact-milliseconds)
+                                             cache-entry-lifetime-msec)
+                                          interface
+                                          sender-hardware-address)))
+            (case oper
+              [(1) ;; request
+               (when (set-member? (assertions) (cache-key ptype target-protocol-address))
+                 (log-info "~a ARP answering request for ~a/~a"
+                           interface-name
+                           ptype
+                           (pretty-bytes target-protocol-address))
+                 (send! (build-packet sender-hardware-address
+                                      ptype
+                                      2 ;; reply
+                                      hwaddr
+                                      target-protocol-address
+                                      sender-hardware-address
+                                      sender-protocol-address)))]
+              [(2) (void)] ;; reply
+              [else (void)])))
+         (else #f)))
+
+  (during (arp-assertion $protocol $protocol-address interface-name)
+          (define a (cache-key protocol protocol-address))
+          (on-start (assertions (set-add (assertions) a))
+                    (log-info "~a ARP Announcing ~a as ~a"
+                              interface-name
+                              (pretty-bytes (cache-key-address a))
+                              (pretty-bytes hwaddr))
+                    (send! (build-packet broadcast-ethernet-address
+                                         (cache-key-protocol a)
+                                         2 ;; reply -- gratuitous announcement
+                                         hwaddr
+                                         (cache-key-address a)
+                                         hwaddr
+                                         (cache-key-address a))))
+          (on-stop (assertions (set-remove (assertions) a))))
+
+  (during (observe (arp-query $protocol $protocol-address interface _))
+          (define key (cache-key protocol protocol-address))
+          (on-start (queries (set-add (queries) key))
+                    (send-questions!))
+          (on-stop (queries (set-remove (queries) key)))
+          (assert #:when (hash-has-key? (cache) key)
+                  (match (hash-ref (cache) key)
+                    [(cache-value _ ifname addr)
+                     (arp-query protocol protocol-address ifname addr)]))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-arp-driver)

examples/netstack/incremental-highlevel/checksum.rkt

@@ -0,0 +1,52 @@
+#lang racket/base
+
+(provide ones-complement-sum16 ip-checksum)
+
+(require bitsyntax)
+(require "dump-bytes.rkt")
+
+(define (ones-complement-+16 a b)
+  (define c (+ a b))
+  (bitwise-and #xffff (+ (arithmetic-shift c -16) c)))
+
+(define (ones-complement-sum16 bs)
+  (bit-string-case bs
+    ([ (n :: integer bytes 2) (rest :: binary) ]
+     (ones-complement-+16 n (ones-complement-sum16 rest)))
+    ([ odd-byte ]
+     (arithmetic-shift odd-byte 8))
+    ([ ]
+     0)))
+
+(define (ones-complement-negate16-safely x)
+  (define r (bitwise-and #xffff (bitwise-not x)))
+  (if (= r 0) #xffff r))
+
+(define (ip-checksum offset blob #:pseudo-header [pseudo-header #""])
+  (bit-string-case blob
+    ([ (prefix :: binary bytes offset)
+       (:: binary bytes 2)
+       (suffix :: binary) ]
+     ;; (log-info "Packet pre checksum:\n~a" (dump-bytes->string blob))
+     (define result (ones-complement-+16
+		     (ones-complement-sum16 pseudo-header)
+		     (ones-complement-+16 (ones-complement-sum16 prefix)
+					  (ones-complement-sum16 suffix))))
+     ;; (log-info "result: ~a" (number->string result 16))
+     (define checksum (ones-complement-negate16-safely result))
+     ;; (log-info "Checksum ~a" (number->string checksum 16))
+     (define final-packet (bit-string (prefix :: binary)
+				      (checksum :: integer bytes 2)
+				      (suffix :: binary)))
+     ;; (log-info "Packet with checksum:\n~a" (dump-bytes->string final-packet))
+     final-packet)))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (ones-complement-negate16-safely
+		 (ones-complement-sum16 (bytes #x45 #x00 #x00 #x54
+					       #x00 #x00 #x00 #x00
+					       #x40 #x01 #x00 #x00
+					       #xc0 #xa8 #x01 #xde
+					       #xc0 #xa8 #x01 #x8f)))
+		#xf5eb))

examples/netstack/incremental-highlevel/configuration.rkt

@@ -0,0 +1,21 @@
+#lang racket/base
+
+(provide (struct-out ethernet-interface)
+	 (struct-out host-route)
+	 (struct-out gateway-route)
+	 (struct-out net-route)
+
+         (struct-out route-up))
+
+(struct ethernet-interface (name hwaddr) #:prefab)
+
+;; A Route is one of
+;;  - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route
+;;  - (gateway-route NetAddrBytes NetmaskNat IpAddrBytes InterfaceName), a gateway for a subnet
+;;  - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet
+;; NetmaskNat in a net-route is a default route.
+(struct host-route (ip-addr netmask interface-name) #:prefab)
+(struct gateway-route (network-addr netmask gateway-addr interface-name) #:prefab)
+(struct net-route (network-addr netmask link) #:prefab)
+
+(struct route-up (route) #:prefab) ;; assertion: the given Route is running

examples/netstack/incremental-highlevel/cpingresp.c

@@ -0,0 +1,219 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdint.h>
+#include <ctype.h>
+
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/time.h>
+#include <sys/ioctl.h>
+
+#include <fcntl.h>
+#include <err.h>
+#include <errno.h>
+#include <unistd.h>
+#include <ifaddrs.h>
+
+#include <net/if.h>
+#include <net/ethernet.h>
+#include <arpa/inet.h> /* for htons */
+
+#include <pthread.h>
+
+#include <net/if_arp.h>
+#include <netpacket/packet.h>
+
+static int lookupInterfaceInfo(int sock, char const *interfaceName, int info, struct ifreq *ifr) {
+  strncpy(ifr->ifr_name, interfaceName, IFNAMSIZ);
+  if (ioctl(sock, info, ifr) < 0) {
+    perror("ioctl error while looking performing ioctl on interface");
+    fprintf(stderr, "(ioctl number 0x%08x, interface %s)\n", info, interfaceName);
+    return -1;
+  } else {
+    return 0;
+  }
+}
+
+static int bindToInterface(int sock, char const *interfaceName) {
+  struct ifreq ifr;
+  struct sockaddr_ll socketAddress;
+
+  if (lookupInterfaceInfo(sock, interfaceName, SIOCGIFINDEX, &ifr) < 0) {
+    return -1;
+  }
+
+  socketAddress.sll_family = AF_PACKET;
+  socketAddress.sll_protocol = htons(ETH_P_ALL);
+  socketAddress.sll_ifindex = ifr.ifr_ifindex;
+
+  if (bind(sock, (struct sockaddr *) &socketAddress, sizeof(socketAddress)) < 0) {
+    perror("Bind error");
+    return -1;
+  }
+
+  return 0;
+}
+
+static int openSocket(char const *interfaceName) {
+  int sock = socket(AF_PACKET, SOCK_RAW, htons(ETH_P_ALL));
+  if (sock < 0) {
+    perror("Socket error");
+    return -1;
+  }
+
+  if (bindToInterface(sock, interfaceName) == -1) {
+    return -1;
+  }
+
+  return sock;
+}
+
+/* hwaddr should be of length ETH_ALEN */
+static int socket_hwaddr(int sock, char const *interfaceName, char *hwaddr) {
+  struct ifreq ifr;
+
+  if (lookupInterfaceInfo(sock, interfaceName, SIOCGIFHWADDR, &ifr) < 0) {
+    return -1;
+  }
+
+  if (ifr.ifr_hwaddr.sa_family != ARPHRD_ETHER) {
+    return -1;
+  }
+
+  memcpy(hwaddr, ifr.ifr_hwaddr.sa_data, ETH_ALEN);
+  return 0;
+}
+
+static void dump_row(long count, int numinrow, int *chs) {
+  int i;
+
+  printf("%08lX:", count - numinrow);
+
+  if (numinrow > 0) {
+    for (i = 0; i < numinrow; i++) {
+      if (i == 8)
+	printf(" :");
+      printf(" %02X", chs[i]);
+    }
+    for (i = numinrow; i < 16; i++) {
+      if (i == 8)
+	printf(" :");
+      printf("   ");
+    }
+    printf("  ");
+    for (i = 0; i < numinrow; i++) {
+      if (isprint(chs[i]))
+	printf("%c", chs[i]);
+      else
+	printf(".");
+    }
+  }
+  printf("\n");
+}
+
+static int rows_eq(int *a, int *b) {
+  int i;
+
+  for (i=0; i<16; i++)
+    if (a[i] != b[i])
+      return 0;
+
+  return 1;
+}
+
+void dump_buffer_to_stdout(void *buf_v, int len, int hexmode) {
+  unsigned char *buf = (unsigned char *) buf_v;
+  long count = 0;
+  int numinrow = 0;
+  int chs[16];
+  int oldchs[16];
+  int showed_dots = 0;
+  int i;
+
+  if (hexmode) {
+    for (i = 0; i < len; i++) {
+      int ch = buf[i];
+
+      if (numinrow == 16) {
+	int i;
+
+	if (rows_eq(oldchs, chs)) {
+	  if (!showed_dots) {
+	    showed_dots = 1;
+	    printf("          .. .. .. .. .. .. .. .. : .. .. .. .. .. .. .. ..\n");
+	  }
+	} else {
+	  showed_dots = 0;
+	  dump_row(count, numinrow, chs);
+	}
+
+	for (i=0; i<16; i++)
+	  oldchs[i] = chs[i];
+
+	numinrow = 0;
+      }
+
+      count++;
+      chs[numinrow++] = ch;
+    }
+
+    dump_row(count, numinrow, chs);
+
+    if (numinrow != 0)
+      printf("%08lX:\n", count);
+  } else {
+    fwrite(buf, 1, len, stdout);
+    printf("\n");
+    fflush(NULL);
+  }
+}
+
+int main(int argc, char const *argv[]) {
+  int handle = openSocket("eth0");
+  uint8_t buf[65536];
+
+  while (1) {
+    ssize_t len = recv(handle, &buf[0], sizeof(buf), MSG_TRUNC);
+    if (len == -1) {
+      perror("recv");
+      break;
+    }
+
+    uint8_t *ipbuf = buf + 14;
+
+    uint32_t self_ip = 0x810a735e;
+
+    uint32_t remote_ip = ntohl(*(int *)(&ipbuf[12]));
+    uint32_t local_ip = ntohl(*(int *)(&ipbuf[16]));
+
+    if (local_ip == self_ip) {
+      printf("Got ping from %d.%d.%d.%d\n", ipbuf[12], ipbuf[13], ipbuf[14], ipbuf[15]);
+      if ((len >= 28) && (ipbuf[9] == 1) && (ipbuf[20] == 8)) {
+        ipbuf[20] = 0;
+        {
+          short *icmp_cksum = (short *) (&ipbuf[22]);
+          *icmp_cksum = htons(ntohs(*icmp_cksum) + 0x0800);
+        }
+        *(int *)(&ipbuf[12]) = htonl(local_ip);
+        *(int *)(&ipbuf[16]) = htonl(remote_ip);
+
+        {
+          uint8_t mac[6];
+          memcpy(mac, buf, 6);
+          memcpy(buf, buf+6, 6);
+          memcpy(buf+6, mac, 6);
+        }
+        {
+          ssize_t written = write(handle, buf, len);
+          if (written != len) {
+            perror("write");
+            break;
+          }
+        }
+      }
+    }
+  }
+
+  return 0;
+}

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

@@ -0,0 +1,21 @@
+#lang syndicate
+;; Demonstration stack configuration for various hosts.
+
+(require racket/match)
+(require (only-in mzlib/os gethostname))
+(require (only-in racket/string string-split))
+(require "configuration.rkt")
+
+(spawn
+ (match (gethostname)
+   ["stockholm.ccs.neu.edu"
+    (assert (host-route (bytes 129 10 115 94) 24 "eth0"))
+    (assert (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0"))]
+   [other ;; assume a private network
+    (define interface
+      (match (car (string-split other "."))
+        ["skip" "en0"]
+        ["leap" "wlp4s0"] ;; wtf
+        [_ "wlan0"]))
+    (assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
+    (assert (host-route (bytes 192 168 1 222) 24 interface))]))

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

@@ -0,0 +1,80 @@
+#lang racket/base
+;; Copyright (C) 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>
+;;
+;; dump-bytes.rkt is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; dump-bytes.rkt is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with dump-bytes.rkt. If not, see <http://www.gnu.org/licenses/>.
+
+;; Pretty hex dump output of a Bytes.
+
+(provide dump-bytes!
+	 dump-bytes->string
+	 pretty-bytes)
+
+(require (only-in bitsyntax bit-string->bytes))
+(require (only-in file/sha1 bytes->hex-string))
+
+(define (pretty-bytes bs)
+  (bytes->hex-string (bit-string->bytes bs)))
+
+;; Exact Exact -> String
+;; Returns the "0"-padded, width-digit hex representation of n
+(define (hex width n)
+  (define s (number->string n 16))
+  (define slen (string-length s))
+  (cond
+   ((< slen width) (string-append (make-string (- width slen) #\0) s))
+   ((= slen width) s)
+   ((> slen width) (substring s 0 width))))
+
+;; Bytes Exact -> Void
+;; Prints a pretty hex/ASCII dump of bs on (current-output-port).
+(define (dump-bytes! bs0 [requested-count #f] #:base [baseaddr 0])
+  (define bs (bit-string->bytes bs0))
+  (define count (if requested-count (min requested-count (bytes-length bs)) (bytes-length bs)))
+  (define clipped (subbytes bs 0 count))
+  (define (dump-hex i)
+    (if (< i count)
+	(display (hex 2 (bytes-ref clipped i)))
+	(display "  "))
+    (display #\space))
+  (define (dump-char i)
+    (if (< i count)
+	(let ((ch (bytes-ref clipped i)))
+	  (if (<= 32 ch 127)
+	      (display (integer->char ch))
+	      (display #\.)))
+	(display #\space)))
+  (define (for-each-between f low high)
+    (do ((i low (+ i 1)))
+	((= i high))
+      (f i)))
+  (define (dump-line i)
+    (display (hex 8 (+ i baseaddr)))
+    (display #\space)
+    (for-each-between dump-hex i (+ i 8))
+    (display ": ")
+    (for-each-between dump-hex (+ i 8) (+ i 16))
+    (display #\space)
+    (for-each-between dump-char i (+ i 8))
+    (display " : ")
+    (for-each-between dump-char (+ i 8) (+ i 16))
+    (newline))
+  (do ((i 0 (+ i 16)))
+      ((>= i count))
+    (dump-line i)))
+
+(define (dump-bytes->string bs [requested-count #f] #:base [baseaddr 0])
+  (define s (open-output-string))
+  (parameterize ((current-output-port s))
+    (dump-bytes! bs requested-count #:base baseaddr))
+  (get-output-string s))

examples/netstack/incremental-highlevel/ethernet.rkt

@@ -0,0 +1,125 @@
+#lang syndicate
+;; Ethernet driver
+
+(provide (struct-out ethernet-packet)
+	 zero-ethernet-address
+	 broadcast-ethernet-address
+	 interface-names
+	 spawn-ethernet-driver
+	 ethernet-packet-pattern
+	 lookup-ethernet-hwaddr)
+
+(require/activate syndicate/drivers/timer)
+(require racket/set)
+(require racket/match)
+(require racket/async-channel)
+
+(require packet-socket)
+(require bitsyntax)
+
+(require "configuration.rkt")
+(require "dump-bytes.rkt")
+
+(struct ethernet-packet (interface from-wire? source destination ethertype body) #:prefab)
+
+(define zero-ethernet-address (bytes 0 0 0 0 0 0))
+(define broadcast-ethernet-address (bytes 255 255 255 255 255 255))
+
+(define interface-names (raw-interface-names))
+(log-info "Device names: ~a" interface-names)
+
+(define (spawn-ethernet-driver)
+  (spawn #:name 'ethernet-driver
+   (during/spawn
+    (observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _))
+    #:name (list 'ethernet-interface interface-name)
+
+    (define h (raw-interface-open interface-name))
+    (when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
+    (log-info "Opened interface ~a, yielding handle ~v" interface-name h)
+
+    (define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
+    (assert interface)
+
+    (define control-ch (make-async-channel))
+    (thread (lambda () (interface-packet-read-loop interface h control-ch)))
+
+    (on-start (flush!) ;; ensure all subscriptions are in place
+              (async-channel-put control-ch 'unblock)
+              (spawn #:name (list 'ethernet-interface-quit-monitor interface-name)
+                     (on (retracted interface)
+                         (async-channel-put control-ch 'quit))))
+
+    (on (message (inbound ($ p (ethernet-packet interface #t _ _ _ _))))
+        ;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
+        ;;           (ethernet-interface-name (ethernet-packet-interface p))
+        ;;           (pretty-bytes (ethernet-packet-source p))
+        ;;           (pretty-bytes (ethernet-packet-destination p))
+        ;;           (number->string (ethernet-packet-ethertype p) 16))
+        ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
+        (send! p))
+
+    (on (message ($ p (ethernet-packet interface #f _ _ _ _)))
+        ;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
+        ;;           (ethernet-interface-name (ethernet-packet-interface p))
+        ;;           (pretty-bytes (ethernet-packet-source p))
+        ;;           (pretty-bytes (ethernet-packet-destination p))
+        ;;           (number->string (ethernet-packet-ethertype p) 16))
+        ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
+        (raw-interface-write h (encode-ethernet-packet p))))))
+
+(define (interface-packet-read-loop interface h control-ch)
+  (define (blocked)
+    (match (async-channel-get control-ch)
+      ['unblock (unblocked)]
+      ['quit (void)]))
+  (define (unblocked)
+    (match (async-channel-try-get control-ch)
+      ['unblock (unblocked)]
+      ['quit (void)]
+      [#f
+       (define p (raw-interface-read h))
+       (define decoded (decode-ethernet-packet interface p))
+       (when decoded (send-ground-message decoded))
+       (unblocked)]))
+  (blocked)
+  (raw-interface-close h))
+
+(define (decode-ethernet-packet interface p)
+  (bit-string-case p
+    ([ (destination :: binary bytes 6)
+       (source :: binary bytes 6)
+       (ethertype :: integer bytes 2)
+       (body :: binary) ]
+     (ethernet-packet interface
+		      #t
+		      (bit-string->bytes source)
+		      (bit-string->bytes destination)
+		      ethertype
+		      (bit-string->bytes body)))
+    (else #f)))
+
+(define (encode-ethernet-packet p)
+  (match-define (ethernet-packet _ _ source destination ethertype body) p)
+  (bit-string->bytes
+   (bit-string (destination :: binary bytes 6)
+	       (source :: binary bytes 6)
+	       (ethertype :: integer bytes 2)
+	       (body :: binary))))
+
+(define (ethernet-packet-pattern interface-name from-wire? ethertype)
+  (ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?))
+
+(define (lookup-ethernet-hwaddr interface-name)
+  (define timer-id (gensym 'lookup-ethernet-hwaddr))
+  (react/suspend (k)
+                 (on-start (send! (set-timer timer-id 5000 'relative)))
+                 (stop-when (message (timer-expired timer-id _))
+                            (log-info "Lookup of ethernet interface ~v failed" interface-name)
+                            (k #f))
+                 (stop-when (asserted (ethernet-interface interface-name $hwaddr))
+                            (k hwaddr))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-ethernet-driver)

examples/netstack/incremental-highlevel/fetchurl.rkt

@@ -0,0 +1,26 @@
+#lang syndicate
+
+(require/activate syndicate/drivers/timer)
+(require/activate "ethernet.rkt")
+(require/activate "arp.rkt")
+(require/activate "ip.rkt")
+(require/activate "tcp.rkt")
+(require/activate "udp.rkt")
+(require/activate "demo-config.rkt")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(let ()
+  (define local-handle (tcp-handle 'httpclient))
+  (define remote-handle (tcp-address "81.4.107.66" 80))
+
+  (actor (assert (advertise (tcp-channel local-handle remote-handle _)))
+         (on (asserted (advertise (tcp-channel remote-handle local-handle _)))
+             (send! (tcp-channel local-handle
+                                 remote-handle
+                                 #"GET / HTTP/1.0\r\nHost: leastfixedpoint.com\r\n\r\n")))
+         (stop-when (retracted (advertise (tcp-channel remote-handle local-handle _)))
+                    (printf "URL fetcher exiting.\n"))
+         (on (message (tcp-channel remote-handle local-handle $bs))
+             (printf "----------------------------------------\n~a\n" bs)
+             (printf "----------------------------------------\n"))))

examples/netstack/incremental-highlevel/ip.rkt

@@ -0,0 +1,268 @@
+#lang syndicate
+
+(provide (struct-out ip-packet)
+	 ip-address->hostname
+	 ip-string->ip-address
+	 apply-netmask
+	 ip-address-in-subnet?
+         query-local-ip-addresses
+	 broadcast-ip-address
+	 spawn-ip-driver)
+
+(require racket/set)
+(require (only-in racket/string string-split))
+(require bitsyntax)
+(require syndicate/protocol/advertise)
+
+(require "dump-bytes.rkt")
+(require "configuration.rkt")
+(require "checksum.rkt")
+
+(require/activate syndicate/drivers/timer)
+(require/activate "ethernet.rkt")
+(require/activate "arp.rkt")
+
+(struct ip-packet (source-interface ;; string for an ethernet interface, or #f for local interfaces
+		   source
+		   destination
+		   protocol
+		   options
+		   body)
+	#:prefab) ;; TODO: more fields
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (ip-address->hostname bs)
+  (bit-string-case bs
+    ([ a b c d ] (format "~a.~a.~a.~a" a b c d))))
+
+(define (ip-string->ip-address str)
+  (list->bytes (map string->number (string-split str "."))))
+
+(define (apply-netmask addr netmask)
+  (bit-string-case addr
+    ([ (n :: integer bytes 4) ]
+     (bit-string ((bitwise-and n (arithmetic-shift #x-100000000 (- netmask)))
+		  :: integer bytes 4)))))
+
+(define (ip-address-in-subnet? addr network netmask)
+  (equal? (apply-netmask network netmask)
+	  (apply-netmask addr netmask)))
+
+(define broadcast-ip-address (bytes 255 255 255 255))
+
+(define (query-local-ip-addresses)
+  (query-set local-ips (host-route $addr _ _) addr))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (spawn-ip-driver)
+  (spawn #:name 'ip-driver
+   (during/spawn (host-route $my-address $netmask $interface-name)
+                 (assert (route-up (host-route my-address netmask interface-name)))
+                 (do-host-route my-address netmask interface-name))
+   (during/spawn (gateway-route $network $netmask $gateway-addr $interface-name)
+                 (assert (route-up
+                          (gateway-route $network $netmask $gateway-addr $interface-name)))
+                 (do-gateway-route network netmask gateway-addr interface-name))
+   (during/spawn (net-route $network-addr $netmask $link)
+                 (assert (route-up (net-route network-addr netmask link)))
+                 (do-net-route network-addr netmask link))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Local IP route
+
+(define (do-host-route my-address netmask interface-name)
+  (let ((network-addr (apply-netmask my-address netmask)))
+    (do-normal-ip-route (host-route my-address netmask interface-name)
+                        network-addr
+                        netmask
+                        interface-name))
+
+  (assert (advertise (ip-packet _ my-address _ PROTOCOL-ICMP _ _)))
+  (assert (arp-assertion IPv4-ethertype my-address interface-name))
+  (on (message (ip-packet _ $peer-address my-address PROTOCOL-ICMP _ $body))
+      (bit-string-case body
+        ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum
+         (case type
+           [(8) ;; ECHO (0 is ECHO-REPLY)
+            (log-info "Ping of ~a from ~a"
+                      (pretty-bytes my-address)
+                      (pretty-bytes peer-address))
+            (define reply-data0 (bit-string 0
+                                            code
+                                            (0 :: integer bytes 2) ;; TODO
+                                            (rest :: binary)))
+            (send! (ip-packet #f
+                              my-address
+                              peer-address
+                              PROTOCOL-ICMP
+                              #""
+                              (ip-checksum 2 reply-data0)))]
+           [else
+            (log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a"
+                      type
+                      code
+                      checksum
+                      (pretty-bytes my-address)
+                      (pretty-bytes peer-address)
+                      (dump-bytes->string rest))]))
+        (else #f))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gateway IP route
+
+(struct gateway-route-state (routes gateway-interface gateway-hwaddr) #:transparent)
+
+(define (do-gateway-route network netmask gateway-addr interface-name)
+  (define the-route (gateway-route network netmask gateway-addr interface-name))
+
+  (field [routes (set)])
+  (query-set* routes (host-route $addr $netmask _) (list addr netmask))
+  (query-set* routes (gateway-route $addr $netmask _ _) (list addr netmask))
+  (query-set* routes (net-route $addr $netmask _) (list addr netmask))
+
+  (field [gateway-interface #f]
+         [gateway-hwaddr #f])
+  (on (asserted (arp-query IPv4-ethertype
+                           gateway-addr
+                           ($ iface (ethernet-interface interface-name _))
+                           $hwaddr))
+      (when (not (gateway-hwaddr))
+        (log-info "Discovered gateway ~a at ~a on interface ~a."
+                  (ip-address->hostname gateway-addr)
+                  (ethernet-interface-name iface)
+                  (pretty-bytes hwaddr)))
+      (gateway-interface iface)
+      (gateway-hwaddr hwaddr))
+
+  (define (covered-by-some-other-route? addr)
+    (for/or ([r (in-set (routes))])
+      (match-define (list net msk) r)
+      (and (positive? msk)
+	   (ip-address-in-subnet? addr net msk))))
+
+  (on (message ($ p (ip-packet _ _ _ _ _ _)))
+      (when (not (gateway-interface))
+        (log-warning "Gateway hwaddr for ~a not known, packet dropped."
+                     (ip-address->hostname gateway-addr)))
+      (when (and (gateway-interface)
+                 (not (equal? (ip-packet-source-interface p)
+                              (ethernet-interface-name (gateway-interface))))
+                 (not (covered-by-some-other-route? (ip-packet-destination p))))
+        (send! (ethernet-packet (gateway-interface)
+                                #f
+                                (ethernet-interface-hwaddr (gateway-interface))
+                                (gateway-hwaddr)
+                                IPv4-ethertype
+                                (format-ip-packet p))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; General net route
+
+(define (do-net-route network-addr netmask link)
+  (do-normal-ip-route (net-route network-addr netmask link) network-addr netmask link))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Normal IP route
+
+(define (do-normal-ip-route the-route network netmask interface-name)
+  (assert (arp-interface interface-name))
+  (on (message (ethernet-packet (ethernet-interface interface-name _) #t _ _ IPv4-ethertype $body))
+      (define p (parse-ip-packet interface-name body))
+      (when p (send! p)))
+  (on (message ($ p (ip-packet _ _ _ _ _ _)))
+      (define destination (ip-packet-destination p))
+      (when (and (not (equal? (ip-packet-source-interface p) interface-name))
+                 (ip-address-in-subnet? destination network netmask))
+        (define timer-id (gensym 'ippkt))
+        ;; v Use `spawn` instead of `react` to avoid gratuitous packet
+        ;; reordering.
+        (spawn (on-start (send! (set-timer timer-id 5000 'relative)))
+               (stop-when (message (timer-expired timer-id _))
+                 (log-warning "ARP lookup of ~a failed, packet dropped"
+                              (ip-address->hostname destination)))
+               (stop-when (asserted (arp-query IPv4-ethertype
+                                               destination
+                                               ($ interface (ethernet-interface interface-name _))
+                                               $destination-hwaddr))
+                 (send! (ethernet-packet interface
+                                         #f
+                                         (ethernet-interface-hwaddr interface)
+                                         destination-hwaddr
+                                         IPv4-ethertype
+                                         (format-ip-packet p))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define IPv4-ethertype #x0800)
+
+(define IP-VERSION 4)
+(define IP-MINIMUM-HEADER-LENGTH 5)
+
+(define PROTOCOL-ICMP 1)
+
+(define default-ttl 64)
+
+(define (parse-ip-packet interface-name body)
+  ;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body))
+  (bit-string-case body
+    ([ (= IP-VERSION :: bits 4)
+       (header-length :: bits 4)
+       service-type
+       (total-length :: bits 16)
+       (id :: bits 16)
+       (flags :: bits 3)
+       (fragment-offset :: bits 13)
+       ttl
+       protocol
+       (header-checksum :: bits 16) ;; TODO: check checksum
+       (source-ip0 :: binary bits 32)
+       (destination-ip0 :: binary bits 32)
+       (rest :: binary) ]
+     (let* ((source-ip (bit-string->bytes source-ip0))
+	    (destination-ip (bit-string->bytes destination-ip0))
+	    (options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH)))
+	    (data-length (- total-length (* 4 header-length))))
+       (if (and (>= header-length 5)
+		(>= (bit-string-byte-count body) (* header-length 4)))
+	   (bit-string-case rest
+	     ([ (opts :: binary bytes options-length)
+		(data :: binary bytes data-length)
+		(:: binary) ] ;; Very short ethernet packets have a trailer of zeros
+	      (ip-packet interface-name
+			 (bit-string->bytes source-ip)
+			 (bit-string->bytes destination-ip)
+			 protocol
+			 (bit-string->bytes opts)
+			 (bit-string->bytes data))))
+	   #f)))
+    (else #f)))
+
+(define (format-ip-packet p)
+  (match-define (ip-packet _ src dst protocol options body) p)
+
+  (define header-length ;; TODO: ensure options is a multiple of 4 bytes
+    (+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4)))
+
+  (define header0 (bit-string (IP-VERSION :: bits 4)
+			      (header-length :: bits 4)
+			      0 ;; TODO: service type
+			      ((+ (* header-length 4) (bit-string-byte-count body))
+			       :: bits 16)
+			      (0 :: bits 16)  ;; TODO: identifier
+			      (0 :: bits 3)   ;; TODO: flags
+			      (0 :: bits 13)  ;; TODO: fragments
+			      default-ttl
+			      protocol
+			      (0 :: bits 16)
+			      (src :: binary bits 32)
+			      (dst :: binary bits 32)
+			      (options :: binary)))
+  (define full-packet (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary)))
+
+  full-packet)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-ip-driver)

examples/netstack/incremental-highlevel/main.rkt

@@ -0,0 +1,91 @@
+#lang syndicate
+
+(require syndicate/protocol/advertise)
+
+(require/activate syndicate/drivers/timer)
+(require/activate "ethernet.rkt")
+(require/activate "arp.rkt")
+(require/activate "ip.rkt")
+(require/activate "tcp.rkt")
+(require/activate "udp.rkt")
+(require/activate "demo-config.rkt")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(let ()
+  (local-require (only-in racket/string string-trim))
+
+  (struct says (who what) #:prefab)
+  (struct present (who) #:prefab)
+
+  (define (spawn-session them us)
+    (spawn (define (send-to-remote fmt . vs)
+             (send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
+
+           (define (say who fmt . vs)
+             (unless (equal? who user)
+               (send-to-remote "~a ~a\n" who (apply format fmt vs))))
+
+           (define user (gensym 'user))
+           (on-start (send-to-remote "Welcome, ~a.\n" user))
+
+           (stop-when (retracted (inbound (advertise (tcp-channel them us _)))))
+
+           (assert (present user))
+           (on (asserted (present $who)) (say who "arrived."))
+           (on (retracted (present $who)) (say who "departed."))
+
+           (on (message (says $who $what)) (say who "says: ~a" what))
+
+           (assert (outbound (advertise (tcp-channel us them _))))
+           (on (message (inbound (tcp-channel them us $bs)))
+               (send! (says user (string-trim (bytes->string/utf-8 bs)))))))
+
+  (define us (tcp-listener 5999))
+  (dataspace #:name 'chat-dataspace
+             (spawn #:name 'chat-server
+                    (assert (outbound (advertise (observe (tcp-channel _ us _)))))
+                    (on (asserted (inbound (advertise (tcp-channel $them us _))))
+                        (spawn-session them us)))))
+
+(let ((dst (udp-listener 6667)))
+  (spawn #:name 'udp-echo-program
+         (on (message (udp-packet $src dst $body))
+             (log-info "Got packet from ~v: ~v" src body)
+             (send! (udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body)))))))
+
+(let ()
+  (dataspace #:name 'webserver-dataspace
+   (spawn #:name 'webserver-counter
+          (field [counter 0])
+          (on (message 'bump)
+              (send! `(counter ,(counter)))
+              (counter (+ (counter) 1))))
+
+   (define us (tcp-listener 80))
+   (spawn (assert (outbound (advertise (observe (tcp-channel _ us _)))))
+          (during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
+            #:name (list 'webserver-session them)
+            (log-info "Got connection from ~v" them)
+            (assert (outbound (advertise (tcp-channel us them _))))
+            (on (message (inbound (tcp-channel them us _)))) ;; ignore input
+
+            (on-start (send! 'bump))
+            (on (message `(counter ,$counter))
+                (define response
+                  (string->bytes/utf-8
+                   (format (string-append
+                            "HTTP/1.0 200 OK\r\n"
+                            "Content-Type: text/html\r\n"
+                            "\r\n"
+                            "<h1>Hello world from syndicate-netstack!</h1>\n"
+                            "<p>This is running on syndicate's own\n"
+                            "<a href='https://github.com/tonyg/syndicate/'>\n"
+                            "TCP/IP stack</a>.</p>\n"
+                            "<p>There have been ~a requests prior to this one.</p>\n")
+                           counter)))
+                (send! (outbound (tcp-channel us them response)))
+                (for [(i 4)]
+                  (define buf (make-bytes 1024 (+ #x30 i)))
+                  (send! (outbound (tcp-channel us them buf))))
+                (stop-facet (current-facet-id)))))))

examples/netstack/incremental-highlevel/pingresp.rkt

@@ -0,0 +1,67 @@
+#lang racket/base
+;; Simple "ping" responder. Nightmarishly oversimplified. We want to
+;; look at overheads excluding Syndicate. See also
+;; http://dunkels.com/adam/twip.html
+
+(require packet-socket)
+
+(require "dump-bytes.rkt")
+
+(define device-name (or (getenv "PINGRESP_DEVICE") "eth0"))
+(define self-ip (integer-bytes->integer (bytes 129 10 115 94) #f #t))
+
+(define handle (raw-interface-open device-name))
+(unless handle (error 'pingresp "Couldn't open ~a" device-name))
+
+(let loop ()
+  (define eth-buffer (raw-interface-read handle))
+  (define buffer (subbytes eth-buffer 14))
+  (when (>= (bytes-length buffer) 20) ;; enough space for local and remote IP addresses
+    (define local-ip (integer-bytes->integer buffer #f #t 16 20))
+    (define remote-ip (integer-bytes->integer buffer #f #t 12 16))
+    (when (= local-ip self-ip)
+      ;; (printf "Got ping from ~v\n" (bytes->list (subbytes buffer 12 16)))
+      ;; (flush-output)
+      ;; (dump-bytes! eth-buffer)
+      ;; (newline)
+
+      (when (and (>= (bytes-length buffer) 28) ;; IP + ICMP headers
+                 (= (bytes-ref buffer 9) 1) ;; IP protocol
+                 (= (bytes-ref buffer 20) 8) ;; ICMP ECHO
+                 )
+
+        (bytes-set! buffer 20 0) ;; ICMP ECHO_REPLY
+        (integer->integer-bytes (bitwise-and #xffff
+                                             (+ #x0800
+                                                (integer-bytes->integer buffer #f #t 22 24)))
+                                2 #f #t buffer 22) ;; "fix" checksum
+        (integer->integer-bytes local-ip 4 #f #t buffer 12)
+        (integer->integer-bytes remote-ip 4 #f #t buffer 16)
+
+        (define reply
+          (bytes-append (subbytes eth-buffer 6 12)
+                        (subbytes eth-buffer 0 6)
+                        (subbytes eth-buffer 12 14)
+                        buffer))
+        ;; (displayln "Reply:")
+        ;; (dump-bytes! reply)
+        ;; (newline)
+        (raw-interface-write handle reply))))
+  (loop))
+
+(raw-interface-close handle)
+
+
+;; short s[70];
+;; int *l = s;
+;; int t;
+;;
+;;    read(0, s, 140);
+;;     if((s[4] & 65280) == 256 & s[10] == 8) {
+;;       s[10] = 0;
+;;       s[11] += 8;
+;;       t = l[4];
+;;       l[4] = l[3];
+;;       l[3] = t;
+;;       write(1, s, 140);
+;;     }

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

@@ -0,0 +1,36 @@
+#lang syndicate
+;; UDP/TCP port allocator
+
+(provide spawn-port-allocator
+         allocate-port!
+	 (struct-out port-allocation-request)
+         (struct-out port-allocation-reply))
+
+(require racket/set)
+(require "ip.rkt")
+
+(struct port-allocation-request (reqid type) #:prefab)
+(struct port-allocation-reply (reqid port) #:prefab)
+
+(define (spawn-port-allocator allocator-type query-used-ports)
+  (spawn #:name (list 'port-allocator allocator-type)
+         (define local-ips (query-local-ip-addresses))
+         (define used-ports (query-used-ports))
+
+         (begin/dataflow
+           (log-info "port-allocator ~v used ports: ~v" allocator-type (used-ports)))
+
+         (on (message (port-allocation-request $reqid allocator-type))
+             (define currently-used-ports (used-ports))
+             (let randomly-allocate-until-unused ()
+               (define p (+ 1024 (random 64512)))
+               (if (set-member? currently-used-ports p)
+                   (randomly-allocate-until-unused)
+                   (begin (used-ports (set-add currently-used-ports p))
+                          (send! (port-allocation-reply reqid p))))))))
+
+(define (allocate-port! type)
+  (define reqid (gensym 'allocate-port!))
+  (react/suspend (done)
+    (stop-when (message (port-allocation-reply reqid $port)) (done port))
+    (on-start (send! (port-allocation-request reqid type)))))

examples/netstack/incremental-highlevel/tcp.rkt

@@ -0,0 +1,797 @@
+#lang syndicate
+
+(provide (struct-out tcp-address)
+	 (struct-out tcp-handle)
+	 (struct-out tcp-listener)
+	 (struct-out tcp-channel)
+	 spawn-tcp-driver)
+
+(require racket/set)
+(require bitsyntax)
+(require syndicate/protocol/advertise)
+
+(require "dump-bytes.rkt")
+(require "checksum.rkt")
+
+(require/activate syndicate/drivers/timestate)
+(require "ip.rkt")
+(require "port-allocator.rkt")
+
+(module+ test (require rackunit))
+
+(define-logger netstack/tcp)
+
+;; tcp-address/tcp-address : "kernel" tcp connection state machines
+;; tcp-handle/tcp-address : "user" outbound connections
+;; tcp-listener/tcp-address : "user" inbound connections
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Protocol messages
+
+(struct tcp-address (host port) #:prefab)
+(struct tcp-handle (id) #:prefab)
+(struct tcp-listener (port) #:prefab)
+
+(struct tcp-channel (source destination subpacket) #:prefab)
+
+(struct tcp-packet (from-wire?
+		    source-ip
+		    source-port
+		    destination-ip
+		    destination-port
+		    sequence-number
+		    ack-number
+		    flags
+		    window-size
+		    options
+		    data)
+	#:prefab)
+
+;; (tcp-port-allocation Number (U TcpHandle TcpListener))
+(struct tcp-port-allocation (port handle) #:prefab)
+
+(define (summarize-tcp-packet packet)
+  (format "(~a) ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a, payload ~a)"
+          (if (tcp-packet-from-wire? packet) "I" "O")
+          (ip-address->hostname (tcp-packet-source-ip packet))
+          (tcp-packet-source-port packet)
+          (ip-address->hostname (tcp-packet-destination-ip packet))
+          (tcp-packet-destination-port packet)
+          (tcp-packet-sequence-number packet)
+          (tcp-packet-ack-number packet)
+          (tcp-packet-flags packet)
+          (tcp-packet-window-size packet)
+          (bit-string-byte-count (tcp-packet-data packet))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; User-accessible driver startup
+
+(define (spawn-tcp-driver)
+  (spawn-port-allocator 'tcp (lambda () (query-set tcp-ports (tcp-port-allocation $p _) p)))
+  (spawn-kernel-tcp-driver)
+  (spawn #:name 'tcp-inbound-driver
+   (during/spawn (advertise (observe (tcp-channel _ ($ server-addr (tcp-listener _)) _)))
+                 #:name (list 'tcp-listen server-addr)
+                 (match-define (tcp-listener port) server-addr)
+                 (assert (tcp-port-allocation port server-addr))
+                 (on (asserted (advertise (tcp-channel ($ remote-addr (tcp-address _ _))
+                                                       ($ local-addr (tcp-address _ port))
+                                                       _)))
+                     (spawn-relay server-addr remote-addr local-addr))))
+  (spawn #:name 'tcp-outbound-driver
+   (define local-ips (query-local-ip-addresses))
+   (on (asserted (advertise (tcp-channel ($ local-addr (tcp-handle _))
+                                         ($ remote-addr (tcp-address _ _))
+                                         _)))
+       (define port (allocate-port! 'tcp))
+       ;; TODO: Choose a sensible IP address for the outbound
+       ;; connection. We don't have enough information to do this
+       ;; well at the moment, so just pick some available local IP
+       ;; address.
+       ;;
+       ;; Interesting note: In some sense, the right answer is
+       ;; "?". This would give us a form of mobility, where IP
+       ;; addresses only route to a given bucket-of-state and ONLY
+       ;; the port number selects a substate therein. That's not
+       ;; how TCP is defined however so we can't do that.
+       (define appropriate-ip (set-first (local-ips)))
+       (define appropriate-host (ip-address->hostname appropriate-ip))
+       (match-define (tcp-address remote-host remote-port) remote-addr)
+       (define remote-ip (ip-string->ip-address remote-host))
+       (spawn-relay local-addr remote-addr (tcp-address appropriate-host port))
+       (spawn-state-vector remote-ip remote-port appropriate-ip port))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Relay between kernel-level and user-level
+
+(define relay-peer-wait-time-msec 5000)
+
+(define (spawn-relay local-user-addr remote-addr local-tcp-addr)
+  (define timer-name (list 'spawn-relay local-tcp-addr remote-addr))
+
+  (spawn #:name (list 'tcp-relay local-user-addr remote-addr local-tcp-addr)
+   (assert (tcp-port-allocation (tcp-address-port local-tcp-addr) local-user-addr))
+   (assert (advertise (tcp-channel remote-addr local-user-addr _)))
+   (assert (advertise (tcp-channel local-tcp-addr remote-addr _)))
+
+   (field [local-peer-present? #f]
+          [remote-peer-present? #f])
+
+   (on-timeout relay-peer-wait-time-msec
+               (when (not (and (local-peer-present?) (remote-peer-present?)))
+                 (error 'spawn-relay "TCP relay process timed out waiting for peer")))
+
+   (on (asserted (observe (tcp-channel remote-addr local-user-addr _)))
+       (local-peer-present? #t))
+   (stop-when (retracted (observe (tcp-channel remote-addr local-user-addr _))))
+
+   (on (asserted (advertise (tcp-channel remote-addr local-tcp-addr _)))
+       (remote-peer-present? #t))
+   (stop-when (retracted (advertise (tcp-channel remote-addr local-tcp-addr _))))
+
+   (on (message (tcp-channel local-user-addr remote-addr $bs))
+       (send! (tcp-channel local-tcp-addr remote-addr bs)))
+
+   (on (message (tcp-channel remote-addr local-tcp-addr $bs))
+       (send! (tcp-channel remote-addr local-user-addr bs)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Codec & kernel-level driver
+
+(define PROTOCOL-TCP 6)
+
+(define (spawn-kernel-tcp-driver)
+  (spawn #:name 'kernel-tcp-driver
+   (define local-ips (query-local-ip-addresses))
+
+   (define active-state-vectors
+     (query-set active-state-vectors
+                (observe (tcp-packet #t $si $sp $di $dp _ _ _ _ _ _))
+                (list si sp di dp)))
+
+   (define (state-vector-active? statevec)
+     (set-member? (active-state-vectors) statevec))
+
+   (define (analyze-incoming-packet src-ip dst-ip body)
+     (bit-string-case body
+       ([ (src-port :: integer bytes 2)
+          (dst-port :: integer bytes 2)
+          (sequence-number :: integer bytes 4)
+          (ack-number :: integer bytes 4)
+          (data-offset :: integer bits 4)
+          (reserved :: integer bits 3)
+          (ns :: integer bits 1)
+          (cwr :: integer bits 1)
+          (ece :: integer bits 1)
+          (urg :: integer bits 1)
+          (ack :: integer bits 1)
+          (psh :: integer bits 1)
+          (rst :: integer bits 1)
+          (syn :: integer bits 1)
+          (fin :: integer bits 1)
+          (window-size :: integer bytes 2)
+          (checksum :: integer bytes 2) ;; TODO: check checksum
+          (urgent-pointer :: integer bytes 2)
+          (rest :: binary) ]
+        (let* ((flags (set))
+               (statevec (list src-ip src-port dst-ip dst-port))
+               (old-active-state-vectors (active-state-vectors))
+               (spawn-needed? (and (not (state-vector-active? statevec))
+                                   (zero? rst)))) ;; don't bother spawning if it's a rst
+          (define-syntax-rule (set-flags! v ...)
+            (begin (unless (zero? v) (set! flags (set-add flags 'v))) ...))
+          (set-flags! ns cwr ece urg ack psh rst syn fin)
+          (bit-string-case rest
+            ([ (opts :: binary bytes (- (* data-offset 4) 20))
+               (data :: binary) ]
+             (let ((packet (tcp-packet #t
+                                       src-ip
+                                       src-port
+                                       dst-ip
+                                       dst-port
+                                       sequence-number
+                                       ack-number
+                                       flags
+                                       window-size
+                                       (bit-string->bytes opts)
+                                       (bit-string->bytes data))))
+               (log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet packet))
+               (when spawn-needed?
+                 (log-netstack/tcp-debug "  - spawn needed!")
+                 (active-state-vectors (set-add (active-state-vectors) statevec))
+                 (spawn-state-vector src-ip src-port dst-ip dst-port))
+               (send! packet)))
+            (else #f))))
+       (else #f)))
+
+   (begin/dataflow
+     (log-netstack/tcp-debug "SCN yielded statevecs ~v and local-ips ~v"
+                             (active-state-vectors)
+                             (local-ips)))
+
+   (define (deliver-outbound-packet p)
+     (match-define (tcp-packet #f
+                               src-ip
+                               src-port
+                               dst-ip
+                               dst-port
+                               sequence-number
+                               ack-number
+                               flags
+                               window-size
+                               options
+                               data)
+       p)
+     (log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet p))
+     (define (flag-bit sym) (if (set-member? flags sym) 1 0))
+     (define payload (bit-string (src-port :: integer bytes 2)
+                                 (dst-port :: integer bytes 2)
+                                 (sequence-number :: integer bytes 4)
+                                 (ack-number :: integer bytes 4)
+                                 ((+ 5 (quotient (bit-string-byte-count options) 4))
+                                  :: integer bits 4) ;; TODO: enforce 4-byte alignment
+                                 (0 :: integer bits 3)
+                                 ((flag-bit 'ns) :: integer bits 1)
+                                 ((flag-bit 'cwr) :: integer bits 1)
+                                 ((flag-bit 'ece) :: integer bits 1)
+                                 ((flag-bit 'urg) :: integer bits 1)
+                                 ((flag-bit 'ack) :: integer bits 1)
+                                 ((flag-bit 'psh) :: integer bits 1)
+                                 ((flag-bit 'rst) :: integer bits 1)
+                                 ((flag-bit 'syn) :: integer bits 1)
+                                 ((flag-bit 'fin) :: integer bits 1)
+                                 (window-size :: integer bytes 2)
+                                 (0 :: integer bytes 2) ;; checksum location
+                                 (0 :: integer bytes 2) ;; TODO: urgent pointer
+                                 (data :: binary)))
+     (define pseudo-header (bit-string (src-ip :: binary bytes 4)
+                                       (dst-ip :: binary bytes 4)
+                                       0
+                                       PROTOCOL-TCP
+                                       ((bit-string-byte-count payload) :: integer bytes 2)))
+     (send! (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
+                       (ip-checksum 16 payload #:pseudo-header pseudo-header))))
+
+   (on (message (ip-packet $source-if $src $dst PROTOCOL-TCP _ $body))
+       (when (and source-if ;; source-if == #f iff packet originates locally
+                  (set-member? (local-ips) dst))
+         (analyze-incoming-packet src dst body)))
+
+   (on (message ($ p (tcp-packet #f _ _ _ _ _ _ _ _ _ _)))
+       (deliver-outbound-packet p))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Per-connection state vector process
+
+;;---------------------------------------------------------------------------
+;; From the RFC:
+;;
+;;     Send Sequence Variables
+;;
+;;       SND.UNA - send unacknowledged
+;;       SND.NXT - send next
+;;       SND.WND - send window
+;;       SND.UP  - send urgent pointer
+;;       SND.WL1 - segment sequence number used for last window update
+;;       SND.WL2 - segment acknowledgment number used for last window
+;;                 update
+;;       ISS     - initial send sequence number
+;;
+;;     Receive Sequence Variables
+;;
+;;       RCV.NXT - receive next
+;;       RCV.WND - receive window
+;;       RCV.UP  - receive urgent pointer
+;;       IRS     - initial receive sequence number
+;;
+;;   The following diagrams may help to relate some of these variables to
+;;   the sequence space.
+;;
+;;   Send Sequence Space
+;;
+;;                    1         2          3          4
+;;               ----------|----------|----------|----------
+;;                      SND.UNA    SND.NXT    SND.UNA
+;;                                           +SND.WND
+;;
+;;         1 - old sequence numbers which have been acknowledged
+;;         2 - sequence numbers of unacknowledged data
+;;         3 - sequence numbers allowed for new data transmission
+;;         4 - future sequence numbers which are not yet allowed
+;;
+;;                           Send Sequence Space
+;;
+;;                                Figure 4.
+;;
+;;   The send window is the portion of the sequence space labeled 3 in
+;;   figure 4.
+;;
+;;   Receive Sequence Space
+;;
+;;                        1          2          3
+;;                    ----------|----------|----------
+;;                           RCV.NXT    RCV.NXT
+;;                                     +RCV.WND
+;;
+;;         1 - old sequence numbers which have been acknowledged
+;;         2 - sequence numbers allowed for new reception
+;;         3 - future sequence numbers which are not yet allowed
+;;
+;;                          Receive Sequence Space
+;;
+;;                                Figure 5.
+;;
+;;   The receive window is the portion of the sequence space labeled 2 in
+;;   figure 5.
+;;
+;;   There are also some variables used frequently in the discussion that
+;;   take their values from the fields of the current segment.
+;;
+;;     Current Segment Variables
+;;
+;;       SEG.SEQ - segment sequence number
+;;       SEG.ACK - segment acknowledgment number
+;;       SEG.LEN - segment length
+;;       SEG.WND - segment window
+;;       SEG.UP  - segment urgent pointer
+;;       SEG.PRC - segment precedence value
+;;
+;;---------------------------------------------------------------------------
+
+(struct buffer (data ;; bit-string
+		seqn ;; names leftmost byte in data
+		window ;; counts bytes from leftmost byte in data
+		finished?) ;; boolean: true after FIN
+	#:transparent)
+
+;; Regarding acks:
+;;
+;; - we send an ack number that is (buffer-seqn (inbound)) plus the
+;;   number of buffered bytes.
+;;
+;; - acks received allow us to advance (buffer-seqn (outbound)) (that
+;;   is, SND.UNA) to that point, discarding buffered data to do so.
+
+;; Regarding windows:
+;;
+;; - (buffer-window (outbound)) is the size of the peer's receive
+;;   window. Do not allow more than this many bytes to be
+;;   unacknowledged on the wire.
+;;
+;; - (buffer-window (inbound)) is the size of our receive window. The
+;;   peer should not exceed this; we should ignore data received that
+;;   extends beyond this. Once we implement flow control locally
+;;   (ahem) we should move this around, but at present it is fixed.
+
+;; TODO: Zero receive window probe when we have something to say.
+
+(define (buffer-push b data)
+  (struct-copy buffer b [data (bit-string-append (buffer-data b) data)]))
+
+(define inbound-buffer-limit 65535)
+(define maximum-segment-size 536) ;; bytes
+(define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout
+(define user-timeout-msec (* 5 60 1000)) ;; per RFC 793, this should be per-connection, but I
+        ;; cheat; RFC 793 says "the present global default is five minutes", which is
+        ;; reasonable to be getting on with
+
+(define (seq+ a b) (bitwise-and #xffffffff (+ a b)))
+
+;; Always positive
+(define (seq- larger smaller)
+  (if (< larger smaller) ;; wraparound has occurred
+      (+ (- larger smaller) #x100000000)
+      (- larger smaller)))
+
+(define (seq> a b)
+  (not (seq>= b a)))
+
+(define (seq>= a b)
+  (< (seq- a b) #x80000000))
+
+(define (seq-min a b) (if (seq> a b) b a))
+(define (seq-max a b) (if (seq> a b) a b))
+
+(module+ test
+  (check-equal? (seq+ 41724780 1) 41724781)
+  (check-equal? (seq+ 0 1) 1)
+  (check-equal? (seq+ #x80000000 1) #x80000001)
+  (check-equal? (seq+ #xffffffff 1) #x00000000)
+
+  (check-equal? (seq> 41724780 41724780) #f)
+  (check-equal? (seq> 41724781 41724780) #t)
+  (check-equal? (seq> 41724780 41724781) #f)
+
+  (check-equal? (seq> 0 0) #f)
+  (check-equal? (seq> 1 0) #t)
+  (check-equal? (seq> 0 1) #f)
+
+  (check-equal? (seq> #x80000000 #x80000000) #f)
+  (check-equal? (seq> #x80000001 #x80000000) #t)
+  (check-equal? (seq> #x80000000 #x80000001) #f)
+
+  (check-equal? (seq> #xffffffff #xffffffff) #f)
+  (check-equal? (seq> #x00000000 #xffffffff) #t)
+  (check-equal? (seq> #xffffffff #x00000000) #f)
+
+  (check-equal? (seq>= 41724780 41724780) #t)
+  (check-equal? (seq>= 41724781 41724780) #t)
+  (check-equal? (seq>= 41724780 41724781) #f)
+
+  (check-equal? (seq>= 0 0) #t)
+  (check-equal? (seq>= 1 0) #t)
+  (check-equal? (seq>= 0 1) #f)
+
+  (check-equal? (seq>= #x80000000 #x80000000) #t)
+  (check-equal? (seq>= #x80000001 #x80000000) #t)
+  (check-equal? (seq>= #x80000000 #x80000001) #f)
+
+  (check-equal? (seq>= #xffffffff #xffffffff) #t)
+  (check-equal? (seq>= #x00000000 #xffffffff) #t)
+  (check-equal? (seq>= #xffffffff #x00000000) #f))
+
+(define (spawn-state-vector src-ip src-port dst-ip dst-port)
+  (define src (tcp-address (ip-address->hostname src-ip) src-port))
+  (define dst (tcp-address (ip-address->hostname dst-ip) dst-port))
+
+  (spawn
+   #:name (list 'tcp-state-vector
+                (ip-address->hostname src-ip)
+                src-port
+                (ip-address->hostname dst-ip)
+                dst-port)
+   ;; Spawn with initial assertions so we are guaranteed to be sent
+   ;; the packet that led to our creation (in the case of an accepted
+   ;; server connection), and so that we at the same moment gain
+   ;; knowledge of whether we were created on a listening port:
+   #:assertions* (patch-added
+                  (patch-seq (sub (tcp-packet #t src-ip src-port dst-ip dst-port ? ? ? ? ? ?))
+                             (sub (observe (advertise (tcp-channel ? (tcp-listener dst-port) ?))))))
+
+   (define root-facet (current-facet-id))
+
+   (define initial-outbound-seqn
+     ;; Yuck
+     (inexact->exact (truncate (* #x100000000 (random)))))
+
+   (field [outbound (buffer #"!" initial-outbound-seqn 0 #f)] ;; dummy data at SYN position
+          [send-next initial-outbound-seqn] ;; SND.NXT
+          [high-water-mark initial-outbound-seqn]
+
+          [inbound (buffer #"" #f inbound-buffer-limit #f)]
+          [transmission-needed? #f]
+          [syn-acked? #f]
+
+          [latest-peer-activity-time (current-inexact-milliseconds)]
+          ;; ^ the most recent time we heard from our peer
+          [user-timeout-base-time (current-inexact-milliseconds)]
+          ;; ^ when the index of the first outbound unacknowledged byte changed
+
+          ;; RFC 6298
+          [rtt-estimate #f] ;; milliseconds; "SRTT"
+          [rtt-mean-deviation #f] ;; milliseconds; "RTTVAR"
+          [retransmission-timeout 1000] ;; milliseconds
+          [retransmission-deadline #f]
+          [rtt-estimate-seqn-target #f]
+          [rtt-estimate-start-time #f]
+          )
+
+   (define (next-expected-seqn)
+     (define b (inbound))
+     (define v (buffer-seqn b))
+     (and v (seq+ v (bit-string-byte-count (buffer-data b)))))
+
+   (define (set-inbound-seqn! seqn)
+     (inbound (struct-copy buffer (inbound) [seqn seqn])))
+
+   (define (incorporate-segment! data)
+     (when (not (buffer-finished? (inbound)))
+       (inbound (buffer-push (inbound) data))))
+
+   (define (deliver-inbound-locally!)
+     (define b (inbound))
+     (when (not (bit-string-empty? (buffer-data b)))
+       (define chunk (bit-string->bytes (buffer-data b)))
+       (send! (tcp-channel src dst chunk))
+       (inbound (struct-copy buffer b
+                  [data #""]
+                  [seqn (seq+ (buffer-seqn b) (bytes-length chunk))]))))
+
+   ;; (Setof Symbol) -> Void
+   (define (check-fin! flags)
+     (define b (inbound))
+     (when (not (buffer-finished? b))
+       (unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
+         (error 'check-fin "Nonempty inbound buffer"))
+       (when (set-member? flags 'fin)
+         (log-netstack/tcp-debug "Closing inbound stream.")
+         (inbound (struct-copy buffer b
+                    [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
+                    [finished? #t]))
+         (transmission-needed? #t)))) ;; we must send an ack
+
+   ;; -> Void
+   (define (arm-retransmission-timer!)
+     (log-netstack/tcp-debug "Arming retransmission timer (~a ms)" (retransmission-timeout))
+     (retransmission-deadline (+ (current-inexact-milliseconds) (retransmission-timeout))))
+
+   ;; Timestamp -> Void
+   (define (start-rtt-estimate! now)
+     (define target (send-next))
+     (when (seq>= target (high-water-mark))
+       (log-netstack/tcp-debug "Starting RTT estimation; target seqn is ~a" target)
+       (rtt-estimate-start-time now)
+       (rtt-estimate-seqn-target target)))
+
+   ;; -> Void
+   (define (reset-rtt-estimate!)
+     (rtt-estimate-start-time #f)
+     (rtt-estimate-seqn-target #f))
+
+   ;; Timestamp -> Void
+   (define (finish-rtt-estimate! now)
+     (define rtt-measurement (- now (rtt-estimate-start-time)))
+     (reset-rtt-estimate!)
+     (log-netstack/tcp-debug "RTT measurement: ~a ms" rtt-measurement)
+     ;; RFC 6298 Section 2.
+     (cond [(rtt-estimate) => ;; we have a previous estimate, RFC 6298 rule (2.3)
+            (lambda (prev-estimate)
+              (rtt-mean-deviation (+ (* 0.75 (rtt-mean-deviation))
+                                     (* 0.25 (abs (- rtt-measurement prev-estimate)))))
+              (rtt-estimate (+ (* 0.875 prev-estimate)
+                               (* 0.125 rtt-measurement))))]
+           [else ;; no previous estimate, RFC 6298 rule (2.2) applies
+            (rtt-estimate rtt-measurement)
+            (rtt-mean-deviation (/ rtt-measurement 2))])
+     (default-retransmission-timeout!)
+     (log-netstack/tcp-debug "RTT measurement ~a ms; estimate ~a ms; mean deviation ~a ms; RTO ~a ms"
+                             rtt-measurement
+                             (rtt-estimate)
+                             (rtt-mean-deviation)
+                             (retransmission-timeout)))
+
+   (define (default-retransmission-timeout!)
+     (retransmission-timeout
+      (max 200 ;; RFC 6298 rule (2.4), but cribbing from Linux's 200ms minimum
+           (min 60000 ;; (2.5)
+                (+ (rtt-estimate) (* 4 (rtt-mean-deviation))))))) ;; (2.2), (2.3)
+
+   ;; Boolean SeqNum -> Void
+   (define (discard-acknowledged-outbound! ack? ackn)
+     (when ack?
+       (let* ((b (outbound))
+              (base (buffer-seqn b))
+              (ackn (seq-min ackn (high-water-mark)))
+              (ackn (seq-max ackn base))
+              (dist (seq- ackn base)))
+         (user-timeout-base-time (current-inexact-milliseconds))
+         (when (positive? dist)
+           (when (not (syn-acked?)) (syn-acked? #t))
+           (log-netstack/tcp-debug "******** ackn ~a; send-next ~a; high-water-mark ~a"
+                                   ackn
+                                   (send-next)
+                                   (high-water-mark))
+           (when (seq> ackn (send-next)) (send-next ackn))
+           (when (and (rtt-estimate-seqn-target) (seq>= ackn (rtt-estimate-seqn-target)))
+             (finish-rtt-estimate! (current-inexact-milliseconds)))
+
+           (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
+           (outbound (struct-copy buffer b [data remaining-data] [seqn ackn]))
+
+           (default-retransmission-timeout!)
+           (log-netstack/tcp-debug "Positive distance moved by ack, RTO now ~a"
+                                   (retransmission-timeout))
+           (arm-retransmission-timer!)))))
+
+   ;; Nat -> Void
+   (define (update-outbound-window! peer-window)
+     (log-netstack/tcp-debug "Peer's receive-window is now ~a" peer-window)
+     (outbound (struct-copy buffer (outbound) [window peer-window])))
+
+   ;; True iff there is no queued-up data waiting either for
+   ;; transmission or (if transmitted already) for acknowledgement.
+   (define (all-output-acknowledged?)
+     (bit-string-empty? (buffer-data (outbound))))
+
+   (define (close-outbound-stream!)
+     (define b (outbound))
+     (when (not (buffer-finished? b))
+       (outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte
+                   [finished? #t]))
+       (transmission-needed? #t))) ;; the FIN machinery is awkwardly
+                                   ;; different from the usual
+                                   ;; advance-based decision on
+                                   ;; whether to send a packet or not
+
+   ;; SeqNum Boolean Boolean Bytes -> TcpPacket
+   (define (build-outbound-packet seqn mention-syn? mention-fin? payload)
+     (define ackn (next-expected-seqn))
+     (define window (min 65535 ;; limit of field width
+                         (max 0 ;; can't be negative
+                              (- (buffer-window (inbound))
+                                 (bit-string-byte-count (buffer-data (inbound)))))))
+
+     (define flags (set))
+     (when ackn         (set! flags (set-add flags 'ack)))
+     (when mention-syn? (set! flags (set-add flags 'syn)))
+     (when mention-fin? (set! flags (set-add flags 'fin)))
+
+     (tcp-packet #f dst-ip dst-port src-ip src-port
+                 seqn
+                 (or ackn 0)
+                 flags
+                 window
+                 #""
+                 payload))
+
+   (define (outbound-data-chunk offset length)
+     (bit-string-take (bit-string-drop (buffer-data (outbound)) (* offset 8)) (* length 8)))
+
+   ;; Transmit acknowledgements and outbound data.
+   (begin/dataflow
+     (define in-flight-count (seq- (send-next) (buffer-seqn (outbound))))
+
+     (define-values (mention-syn? ;; whether to mention SYN
+                     payload-size ;; how many bytes of payload data to include
+                     mention-fin? ;; whether to mention FIN
+                     advance)     ;; how far to advance send-next
+       (if (syn-acked?)
+           (let* ((effective-window (max 0 (- (buffer-window (outbound)) in-flight-count)))
+                  (stream-ended? (buffer-finished? (outbound)))
+                  (max-advance (- (bit-string-byte-count (buffer-data (outbound))) in-flight-count))
+                  (payload-size (min maximum-segment-size effective-window max-advance)))
+             (if (and stream-ended? ;; there's a FIN enqueued,
+                      (positive? payload-size) ;; we aren't sending nothing at all,
+                      (= payload-size max-advance)) ;; and our payload would cover the FIN
+                 (values #f (- payload-size 1) #t payload-size)
+                 (values #f payload-size #f payload-size)))
+           (cond [(= in-flight-count 0) (values #t 0 #f 1)]
+                 [(= in-flight-count 1) (values #t 0 #f 0)]
+                 [else (error 'send-outbound!
+                              "Invalid state: send-next had advanced too far before SYN")])))
+
+     (when (and (or (next-expected-seqn) (local-peer-seen?))
+                ;; ^ Talk only either if: we know the peer's seqn, or
+                ;; we don't, but a local peer exists, which means
+                ;; we're an outbound connection rather than a
+                ;; listener.
+                (or (transmission-needed?)
+                    (positive? advance))
+                ;; ^ ... and we have something to say. Something to
+                ;; ack, or something to send.
+                )
+       (define packet-seqn (if mention-syn? (buffer-seqn (outbound)) (send-next)))
+       (define packet (build-outbound-packet packet-seqn
+                                             mention-syn?
+                                             mention-fin?
+                                             (outbound-data-chunk in-flight-count payload-size)))
+       (when (positive? advance)
+         (define new-send-next (seq+ (send-next) advance))
+         (send-next new-send-next)
+         (when (seq> new-send-next (high-water-mark))
+           (high-water-mark new-send-next)))
+       (when (transmission-needed?)
+         (transmission-needed? #f))
+
+       ;; (log-netstack/tcp-debug " sending ~v" packet)
+       (send! packet)
+       ;; (if (> (random) 0.5)
+       ;;     (begin (log-netstack/tcp-debug "Send ~a" (summarize-tcp-packet packet))
+       ;;            (send! packet))
+       ;;     (log-netstack/tcp-debug "Drop ~a" (summarize-tcp-packet packet)))
+
+       (when (or mention-syn? mention-fin? (positive? advance))
+         (when (not (retransmission-deadline))
+           (arm-retransmission-timer!))
+         (when (not (rtt-estimate-start-time))
+           (start-rtt-estimate! (current-inexact-milliseconds))))))
+
+   (begin/dataflow
+     (when (and (retransmission-deadline) (all-output-acknowledged?))
+       (log-netstack/tcp-debug "All output acknowledged; disarming retransmission timer")
+       (retransmission-deadline #f)))
+
+   (on #:when (retransmission-deadline) (asserted (later-than (retransmission-deadline)))
+     (send-next (buffer-seqn (outbound)))
+     (log-netstack/tcp-debug "Retransmission deadline fired, RTO was ~a; reset to ~a"
+                             (retransmission-timeout)
+                             (send-next))
+     (update-outbound-window! maximum-segment-size) ;; temporary. Will reopen on next ack
+     (transmission-needed? #t)
+     (retransmission-deadline #f)
+     (reset-rtt-estimate!) ;; give up on current RTT estimation
+     (retransmission-timeout (min 64000 (* 2 (retransmission-timeout))))
+     (log-netstack/tcp-debug "  RTO now ~a" (retransmission-timeout)))
+
+   (define (reset! seqn ackn)
+     (define reset-packet (tcp-packet #f dst-ip dst-port src-ip src-port
+                                      seqn
+                                      ackn
+                                      (set 'ack 'rst)
+                                      0
+                                      #""
+                                      #""))
+     (log-netstack/tcp-warning "Reset ~a" (summarize-tcp-packet reset-packet))
+     (stop-facet root-facet)
+     (send! reset-packet))
+
+   (assert #:when (and (syn-acked?) (not (buffer-finished? (inbound))))
+           (advertise (tcp-channel src dst _)))
+
+   (on-start (log-netstack/tcp-info "Starting state vector ~a-~a" src-port dst-port))
+   (on-stop  (log-netstack/tcp-info "Stopping state vector ~a-~a" src-port dst-port))
+
+   (stop-when #:when (and (buffer-finished? (outbound))
+                          (buffer-finished? (inbound))
+                          (all-output-acknowledged?))
+              (asserted (later-than (+ (latest-peer-activity-time)
+                                       (* 2 1000 maximum-segment-lifetime-sec))))
+    ;; Everything is cleanly shut down, and we just need to wait a while for unexpected
+    ;; packets before we release the state vector.
+    )
+
+   (stop-when #:when (not (all-output-acknowledged?))
+              (asserted (later-than (+ (user-timeout-base-time) user-timeout-msec)))
+    ;; We've been plaintively retransmitting for user-timeout-msec without hearing anything
+    ;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but
+    ;; it will do for now? TODO
+    (log-netstack/tcp-warning "TCP_USER_TIMEOUT fired."))
+
+   (define/query-value local-peer-seen? #f (observe (tcp-channel src dst _)) #t
+     #:on-remove (begin
+                   (log-netstack/tcp-debug "Closing outbound stream.")
+                   (close-outbound-stream!)))
+
+   (define/query-value listener-listening?
+     #f
+     (observe (advertise (tcp-channel _ (tcp-listener dst-port) _)))
+     #t)
+
+   (define (trigger-ack!)
+     (transmission-needed? #t))
+
+   (on (message (tcp-packet #t src-ip src-port dst-ip dst-port
+                            $seqn $ackn $flags $window $options $data))
+       (define expected (next-expected-seqn))
+       (define is-syn? (set-member? flags 'syn))
+       (define is-fin? (set-member? flags 'fin))
+       (cond
+         [(set-member? flags 'rst) (stop-facet root-facet)]
+         [(and (not expected) ;; no syn yet
+               (or (not is-syn?) ;; and this isn't it
+                   (and (not (listener-listening?)) ;; or it is, but no listener...
+                        (not (local-peer-seen?))))) ;; ...and no outbound client
+          (reset! ackn ;; this is *our* seqn
+                  (seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0)))
+                  ;; ^^ this is what we should acknowledge...
+                  )]
+         [else
+          (cond
+            [(not expected) ;; haven't seen syn yet, but we know this is it
+             (set-inbound-seqn! (seq+ seqn 1))
+             (incorporate-segment! data)
+             (trigger-ack!)]
+            [(= expected seqn)
+             (incorporate-segment! data)
+             (when (positive? (bit-string-byte-count data)) (trigger-ack!))]
+            [else
+             (trigger-ack!)])
+          (deliver-inbound-locally!)
+          (check-fin! flags)
+          (discard-acknowledged-outbound! (set-member? flags 'ack) ackn)
+          (update-outbound-window! window)
+          (latest-peer-activity-time (current-inexact-milliseconds))]))
+
+   (on (message (tcp-channel dst src $bs))
+       ;; (log-netstack/tcp-debug "GOT MORE STUFF TO DELIVER ~v" bs)
+
+       (when (all-output-acknowledged?)
+         ;; Only move user-timeout-base-time if there wasn't
+         ;; already some outstanding output.
+         (user-timeout-base-time (current-inexact-milliseconds)))
+
+       (outbound (buffer-push (outbound) bs)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-tcp-driver)

examples/netstack/incremental-highlevel/udp.rkt

@@ -0,0 +1,142 @@
+#lang syndicate
+
+(provide (struct-out udp-remote-address)
+	 (struct-out udp-handle)
+	 (struct-out udp-listener)
+	 udp-address?
+	 udp-local-address?
+	 (struct-out udp-packet)
+	 spawn-udp-driver)
+
+(require racket/set)
+(require bitsyntax)
+(require syndicate/protocol/advertise)
+
+(require "dump-bytes.rkt")
+(require "checksum.rkt")
+(require "configuration.rkt")
+(require "ip.rkt")
+(require "port-allocator.rkt")
+
+;; udp-address/udp-address : "kernel" udp connection state machines
+;; udp-handle/udp-address : "user" outbound connections
+;; udp-listener/udp-address : "user" inbound connections
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Protocol messages
+
+(struct udp-remote-address (host port) #:prefab)
+(struct udp-handle (id) #:prefab)
+(struct udp-listener (port) #:prefab)
+
+(define (udp-address? x)
+  (or (udp-remote-address? x)
+      (udp-local-address? x)))
+
+(define (udp-local-address? x)
+  (or (udp-handle? x)
+      (udp-listener? x)))
+
+;; USER-level protocol
+(struct udp-packet (source destination body) #:prefab)
+
+;; KERNEL-level protocol
+(struct udp-datagram (source-ip source-port destination-ip destination-port body) #:prefab)
+(struct udp-port-allocation (port handle) #:prefab) ;; (udp-port-allocation Number UdpLocalAddress)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; User-accessible driver startup
+
+(define (spawn-udp-driver)
+  (spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p)))
+  (spawn-kernel-udp-driver)
+  (spawn #:name 'udp-driver
+   (on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _)))
+       (spawn-udp-relay (udp-listener-port h) h))
+   (on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _)))
+       (spawn #:name (list 'udp-transient h)
+              (on-start (spawn-udp-relay (allocate-port! 'udp) h))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Relaying
+
+(define (spawn-udp-relay local-port local-user-addr)
+  (spawn #:name (list 'udp-relay local-port local-user-addr)
+         (on-start (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr))
+
+         (define any-remote (udp-remote-address ? ?))
+
+         (stop-when (retracted (observe (udp-packet any-remote local-user-addr _))))
+         (assert (advertise (udp-packet any-remote local-user-addr _)))
+         (assert (udp-port-allocation local-port local-user-addr))
+
+         (during (host-route $ip _ _)
+                 (assert (advertise (udp-datagram ip local-port _ _ _)))
+                 (on (message (udp-datagram $source-ip $source-port ip local-port $bs))
+                     (send!
+                      (udp-packet (udp-remote-address (ip-address->hostname source-ip)
+                                                      source-port)
+                                  local-user-addr
+                                  bs))))
+
+         (define local-ips (query-local-ip-addresses))
+         (on (message (udp-packet local-user-addr ($ remote-addr any-remote) $bs))
+             ;; Choose arbitrary local IP address for outbound packet!
+             ;; TODO: what can be done? Must I examine the routing table?
+             (match-define (udp-remote-address remote-host remote-port) remote-addr)
+             (define remote-ip (ip-string->ip-address remote-host))
+             (send! (udp-datagram (set-first (local-ips))
+                                  local-port
+                                  remote-ip
+                                  remote-port
+                                  bs)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Codec & kernel-level driver
+
+(define PROTOCOL-UDP 17)
+
+(define (spawn-kernel-udp-driver)
+  (spawn #:name 'kernel-udp-driver
+         (assert (advertise (ip-packet #f _ _ PROTOCOL-UDP _ _)))
+
+         (define local-ips (query-local-ip-addresses))
+
+         (on (message (ip-packet $source-if $src-ip $dst-ip PROTOCOL-UDP _ $body))
+             (when (and source-if (set-member? (local-ips) dst-ip))
+               (bit-string-case body
+                 ([ (src-port :: integer bytes 2)
+                    (dst-port :: integer bytes 2)
+                    (length :: integer bytes 2)
+                    (checksum :: integer bytes 2) ;; TODO: check checksum
+                    (data :: binary) ]
+                  (bit-string-case data
+                    ([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes
+                       (:: binary) ]
+                     (send! (udp-datagram src-ip src-port dst-ip dst-port
+                                          (bit-string->bytes payload))))
+                    (else #f)))
+                 (else #f))))
+
+         (on (message (udp-datagram $src-ip $src-port $dst-ip $dst-port $bs))
+             (when (set-member? (local-ips) src-ip)
+               (let* ((payload (bit-string (src-port :: integer bytes 2)
+                                           (dst-port :: integer bytes 2)
+                                           ((+ 8 (bit-string-byte-count bs))
+                                            :: integer bytes 2)
+                                           (0 :: integer bytes 2) ;; checksum location
+                                           (bs :: binary)))
+                      (pseudo-header (bit-string (src-ip :: binary bytes 4)
+                                                 (dst-ip :: binary bytes 4)
+                                                 0
+                                                 PROTOCOL-UDP
+                                                 ((bit-string-byte-count payload)
+                                                  :: integer bytes 2)))
+                      (checksummed-payload (ip-checksum #:pseudo-header pseudo-header
+                                                        6 payload)))
+                 (send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #""
+                                   checksummed-payload)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(spawn-udp-driver)

examples/netstack/monolithic-lowlevel/Makefile

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

examples/netstack/monolithic-lowlevel/arp.rkt

@@ -0,0 +1,235 @@
+#lang racket/base
+;; ARP protocol, http://tools.ietf.org/html/rfc826
+;; Only does ARP-over-ethernet.
+
+(provide (struct-out arp-query)
+	 (struct-out arp-assertion)
+	 (struct-out arp-interface)
+	 spawn-arp-driver)
+
+(require racket/set)
+(require racket/match)
+(require syndicate/monolithic)
+(require syndicate/drivers/timer)
+(require syndicate/demand-matcher)
+(require bitsyntax)
+
+(require "dump-bytes.rkt")
+(require "configuration.rkt")
+(require "ethernet.rkt")
+
+(struct arp-query (protocol protocol-address interface link-address) #:prefab)
+(struct arp-assertion (protocol protocol-address interface-name) #:prefab)
+(struct arp-interface (interface-name) #:prefab)
+
+(struct arp-interface-up (interface-name) #:prefab)
+
+(define ARP-ethertype #x0806)
+(define cache-entry-lifetime-msec (* 14400 1000))
+(define wakeup-interval 5000)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (spawn-arp-driver)
+  (spawn-demand-matcher (arp-interface (?!))
+                        (arp-interface-up (?!))
+			spawn-arp-interface))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(struct cache-key (protocol address) #:transparent)
+(struct cache-value (expiry interface address) #:transparent)
+
+(struct state (cache queries assertions) #:transparent)
+
+(define (spawn-arp-interface interface-name)
+  (log-info "spawn-arp-interface ~v" interface-name)
+  (lookup-ethernet-hwaddr (assertion (arp-interface-up interface-name))
+			  interface-name
+			  (lambda (hwaddr) (spawn-arp-interface* interface-name hwaddr))))
+
+(define (spawn-arp-interface* interface-name hwaddr)
+  (log-info "spawn-arp-interface* ~v ~v" interface-name hwaddr)
+  (define interface (ethernet-interface interface-name hwaddr))
+
+  (define (expire-cache cache)
+    (define now (current-inexact-milliseconds))
+    (define (not-expired? v) (< now (cache-value-expiry v)))
+    (for/hash [((k v) (in-hash cache)) #:when (not-expired? v)]
+      (values k v)))
+
+  (define timer-key (list 'arp interface-name))
+
+  (define (set-wakeup-alarm)
+    (message (set-timer timer-key wakeup-interval 'relative)))
+
+  (define (compute-gestalt cache)
+    (scn/union (subscription (timer-expired timer-key ?))
+               (subscription interface)
+               (subscription (ethernet-packet-pattern interface-name #t ARP-ethertype))
+               (assertion (arp-interface-up interface-name))
+               (subscription (arp-assertion ? ? interface-name))
+               (subscription (observe (arp-query ? ? interface ?)))
+               (for/fold [(g trie-empty)] [((k v) (in-hash cache))]
+                 (assertion-set-union g (assertion (arp-query (cache-key-protocol k)
+                                                              (cache-key-address k)
+                                                              (cache-value-interface v)
+                                                              (cache-value-address v)))))))
+
+  (define (build-packet dest-mac ptype oper sender-ha sender-pa target-ha target-pa)
+    (define hlen (bytes-length target-ha))
+    (define plen (bytes-length target-pa))
+    (define packet (bit-string->bytes
+		    (bit-string (1 :: integer bytes 2)
+				(ptype :: integer bytes 2)
+				hlen
+				plen
+				(oper :: integer bytes 2)
+				(sender-ha :: binary bytes hlen)
+				(sender-pa :: binary bytes plen)
+				(target-ha :: binary bytes hlen)
+				(target-pa :: binary bytes plen))))
+    (ethernet-packet interface
+		     #f
+		     hwaddr
+		     dest-mac
+		     ARP-ethertype
+		     packet))
+
+  (define (analyze-incoming-packet source destination body s)
+    (bit-string-case body
+      ([ (= 1 :: integer bytes 2)
+	 (ptype :: integer bytes 2)
+	 hlen
+	 plen
+	 (oper :: integer bytes 2)
+	 (sender-hardware-address0 :: binary bytes hlen)
+	 (sender-protocol-address0 :: binary bytes plen)
+	 (target-hardware-address0 :: binary bytes hlen)
+	 (target-protocol-address0 :: binary bytes plen)
+	 (:: binary) ;; The extra zeros exist because ethernet packets
+		     ;; have a minimum size. This is, in part, why
+		     ;; IPv4 headers have a total-length field, so
+		     ;; that the zero padding can be removed.
+	 ]
+       (let ()
+	 (define sender-protocol-address (bit-string->bytes sender-protocol-address0))
+	 (define sender-hardware-address (bit-string->bytes sender-hardware-address0))
+	 (define target-protocol-address (bit-string->bytes target-protocol-address0))
+	 (define learned-key (cache-key ptype sender-protocol-address))
+	 (when (and (set-member? (state-queries s) learned-key) ;; it is relevant to our interests
+		    (not (equal? sender-hardware-address
+				 (cache-value-address (hash-ref (state-cache s)
+								learned-key
+								(lambda ()
+								  (cache-value #f #f #f)))))))
+	   (log-info "~a ARP Adding ~a = ~a to cache"
+		     interface-name
+		     (pretty-bytes sender-protocol-address)
+		     (pretty-bytes sender-hardware-address)))
+	 (define cache (hash-set (expire-cache (state-cache s))
+				 learned-key
+				 (cache-value (+ (current-inexact-milliseconds)
+						 cache-entry-lifetime-msec)
+					      interface
+					      sender-hardware-address)))
+	 (transition (struct-copy state s [cache cache])
+                     (list
+                      (case oper
+                        [(1) ;; request
+                         (if (set-member? (state-assertions s)
+                                          (cache-key ptype target-protocol-address))
+                             (begin
+                               (log-info "~a ARP answering request for ~a/~a"
+                                         interface-name
+                                         ptype
+                                         (pretty-bytes target-protocol-address))
+                               (message (build-packet sender-hardware-address
+                                                      ptype
+                                                      2 ;; reply
+                                                      hwaddr
+                                                      target-protocol-address
+                                                      sender-hardware-address
+                                                      sender-protocol-address)))
+                             '())]
+                        [(2) '()] ;; reply
+                        [else '()])
+		      (compute-gestalt cache)))))
+      (else #f)))
+
+  (define queries-projection (observe (arp-query (?!) (?!) ? ?)))
+  (define (gestalt->queries g)
+    (for/set [(e (in-set (trie-project/set #:take 2 g queries-projection)))]
+      (match-define (list ptype pa) e)
+      (cache-key ptype pa)))
+
+  (define assertions-projection (arp-assertion (?!) (?!) ?))
+  (define (gestalt->assertions g)
+    (for/set [(e (in-set (trie-project/set #:take 2 g assertions-projection)))]
+      (match-define (list ptype pa) e)
+      (cache-key ptype pa)))
+
+  (define (analyze-gestalt g s)
+    (define new-assertions (gestalt->assertions g))
+    (define added-assertions (set-subtract new-assertions (state-assertions s)))
+    (define new-s (struct-copy state s [queries (gestalt->queries g)] [assertions new-assertions]))
+    (if (trie-empty? (project-assertions g (arp-interface interface-name)))
+        (quit)
+        (transition new-s
+                    (list
+                     (for/list [(a (in-set added-assertions))]
+                       (log-info "~a ARP Announcing ~a as ~a"
+                                 interface-name
+                                 (pretty-bytes (cache-key-address a))
+                                 (pretty-bytes hwaddr))
+                       (message (build-packet broadcast-ethernet-address
+                                              (cache-key-protocol a)
+                                              2 ;; reply -- gratuitous announcement
+                                              hwaddr
+                                              (cache-key-address a)
+                                              hwaddr
+                                              (cache-key-address a))))))))
+
+  (define (send-questions s)
+    (define unanswered-queries
+      (set-subtract (state-queries s) (list->set (hash-keys (state-cache s)))))
+    (define (some-asserted-pa ptype)
+      (match (filter (lambda (k) (equal? (cache-key-protocol k) ptype))
+		     (set->list (state-assertions s)))
+	['() #f]
+	[(list* k _) (cache-key-address k)]))
+    (transition s
+		(for/list [(q (in-set unanswered-queries))]
+		  (define pa (some-asserted-pa (cache-key-protocol q)))
+		  (log-info "~a ARP Asking for ~a from ~a"
+			    interface-name
+			    (pretty-bytes (cache-key-address q))
+			    (and pa (pretty-bytes pa)))
+		  (when pa
+		    (message (build-packet broadcast-ethernet-address
+                                           (cache-key-protocol q)
+                                           1 ;; request
+                                           hwaddr
+                                           pa
+                                           zero-ethernet-address
+                                           (cache-key-address q)))))))
+
+  (list (set-wakeup-alarm)
+	(actor (lambda (e s)
+		 ;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s)
+		 (match e
+		   [(scn g)
+		    (sequence-transitions (analyze-gestalt g s)
+					  send-questions)]
+		   [(message (ethernet-packet _ _ source destination _ body))
+		    (analyze-incoming-packet source destination body s)]
+		   [(message (timer-expired _ _))
+		    (define new-s (struct-copy state s
+				    [cache (expire-cache (state-cache s))]))
+		    (sequence-transitions (transition new-s
+						      (list (set-wakeup-alarm)
+                                                            (compute-gestalt (state-cache new-s))))
+					  send-questions)]
+		   [_ #f]))
+	       (state (hash) (set) (set))
+	       (compute-gestalt (hash)))))

examples/netstack/monolithic-lowlevel/checksum.rkt

@@ -0,0 +1,52 @@
+#lang racket/base
+
+(provide ones-complement-sum16 ip-checksum)
+
+(require bitsyntax)
+(require "dump-bytes.rkt")
+
+(define (ones-complement-+16 a b)
+  (define c (+ a b))
+  (bitwise-and #xffff (+ (arithmetic-shift c -16) c)))
+
+(define (ones-complement-sum16 bs)
+  (bit-string-case bs
+    ([ (n :: integer bytes 2) (rest :: binary) ]
+     (ones-complement-+16 n (ones-complement-sum16 rest)))
+    ([ odd-byte ]
+     (arithmetic-shift odd-byte 8))
+    ([ ]
+     0)))
+
+(define (ones-complement-negate16-safely x)
+  (define r (bitwise-and #xffff (bitwise-not x)))
+  (if (= r 0) #xffff r))
+
+(define (ip-checksum offset blob #:pseudo-header [pseudo-header #""])
+  (bit-string-case blob
+    ([ (prefix :: binary bytes offset)
+       (:: binary bytes 2)
+       (suffix :: binary) ]
+     ;; (log-info "Packet pre checksum:\n~a" (dump-bytes->string blob))
+     (define result (ones-complement-+16
+		     (ones-complement-sum16 pseudo-header)
+		     (ones-complement-+16 (ones-complement-sum16 prefix)
+					  (ones-complement-sum16 suffix))))
+     ;; (log-info "result: ~a" (number->string result 16))
+     (define checksum (ones-complement-negate16-safely result))
+     ;; (log-info "Checksum ~a" (number->string checksum 16))
+     (define final-packet (bit-string (prefix :: binary)
+				      (checksum :: integer bytes 2)
+				      (suffix :: binary)))
+     ;; (log-info "Packet with checksum:\n~a" (dump-bytes->string final-packet))
+     final-packet)))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (ones-complement-negate16-safely
+		 (ones-complement-sum16 (bytes #x45 #x00 #x00 #x54
+					       #x00 #x00 #x00 #x00
+					       #x40 #x01 #x00 #x00
+					       #xc0 #xa8 #x01 #xde
+					       #xc0 #xa8 #x01 #x8f)))
+		#xf5eb))

examples/netstack/monolithic-lowlevel/configuration.rkt

@@ -0,0 +1,21 @@
+#lang racket/base
+
+(provide (struct-out ethernet-interface)
+	 (struct-out host-route)
+	 (struct-out gateway-route)
+	 (struct-out net-route)
+
+         (struct-out route-up))
+
+(struct ethernet-interface (name hwaddr) #:prefab)
+
+;; A Route is one of
+;;  - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route
+;;  - (gateway-route NetAddrBytes NetmaskNat IpAddrBytes InterfaceName), a gateway for a subnet
+;;  - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet
+;; NetmaskNat in a net-route is a default route.
+(struct host-route (ip-addr netmask interface-name) #:prefab)
+(struct gateway-route (network-addr netmask gateway-addr interface-name) #:prefab)
+(struct net-route (network-addr netmask link) #:prefab)
+
+(struct route-up (route) #:prefab) ;; assertion: the given Route is running

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

@@ -0,0 +1,26 @@
+#lang racket/base
+;; Demonstration stack configuration for various hosts.
+
+(require racket/match)
+(require syndicate/monolithic)
+(require (only-in mzlib/os gethostname))
+(require (only-in racket/string string-split))
+(require "configuration.rkt")
+
+(provide spawn-demo-config)
+
+(define (spawn-demo-config)
+  (actor (lambda (e s) #f)
+         (void)
+         (match (gethostname)
+           ["stockholm.ccs.neu.edu"
+            (scn/union (assertion (host-route (bytes 129 10 115 94) 24 "eth0"))
+                       (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))]
+           [other ;; assume a private network
+            (define interface
+              (match (car (string-split other "."))
+                ["skip" "en0"]
+                ["leap" "wlp4s0"] ;; wtf
+                [_ "wlan0"]))
+            (scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
+                       (assertion (host-route (bytes 192 168 1 222) 24 interface)))])))

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

@@ -0,0 +1,80 @@
+#lang racket/base
+;; Copyright (C) 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>
+;;
+;; dump-bytes.rkt is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; dump-bytes.rkt is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with dump-bytes.rkt. If not, see <http://www.gnu.org/licenses/>.
+
+;; Pretty hex dump output of a Bytes.
+
+(provide dump-bytes!
+	 dump-bytes->string
+	 pretty-bytes)
+
+(require (only-in bitsyntax bit-string->bytes))
+(require (only-in file/sha1 bytes->hex-string))
+
+(define (pretty-bytes bs)
+  (bytes->hex-string (bit-string->bytes bs)))
+
+;; Exact Exact -> String
+;; Returns the "0"-padded, width-digit hex representation of n
+(define (hex width n)
+  (define s (number->string n 16))
+  (define slen (string-length s))
+  (cond
+   ((< slen width) (string-append (make-string (- width slen) #\0) s))
+   ((= slen width) s)
+   ((> slen width) (substring s 0 width))))
+
+;; Bytes Exact -> Void
+;; Prints a pretty hex/ASCII dump of bs on (current-output-port).
+(define (dump-bytes! bs0 [requested-count #f] #:base [baseaddr 0])
+  (define bs (bit-string->bytes bs0))
+  (define count (if requested-count (min requested-count (bytes-length bs)) (bytes-length bs)))
+  (define clipped (subbytes bs 0 count))
+  (define (dump-hex i)
+    (if (< i count)
+	(display (hex 2 (bytes-ref clipped i)))
+	(display "  "))
+    (display #\space))
+  (define (dump-char i)
+    (if (< i count)
+	(let ((ch (bytes-ref clipped i)))
+	  (if (<= 32 ch 127)
+	      (display (integer->char ch))
+	      (display #\.)))
+	(display #\space)))
+  (define (for-each-between f low high)
+    (do ((i low (+ i 1)))
+	((= i high))
+      (f i)))
+  (define (dump-line i)
+    (display (hex 8 (+ i baseaddr)))
+    (display #\space)
+    (for-each-between dump-hex i (+ i 8))
+    (display ": ")
+    (for-each-between dump-hex (+ i 8) (+ i 16))
+    (display #\space)
+    (for-each-between dump-char i (+ i 8))
+    (display " : ")
+    (for-each-between dump-char (+ i 8) (+ i 16))
+    (newline))
+  (do ((i 0 (+ i 16)))
+      ((>= i count))
+    (dump-line i)))
+
+(define (dump-bytes->string bs [requested-count #f] #:base [baseaddr 0])
+  (define s (open-output-string))
+  (parameterize ((current-output-port s))
+    (dump-bytes! bs requested-count #:base baseaddr))
+  (get-output-string s))

examples/netstack/monolithic-lowlevel/ethernet.rkt

@@ -0,0 +1,134 @@
+#lang racket/base
+;; Ethernet driver
+
+(provide (struct-out ethernet-packet)
+	 zero-ethernet-address
+	 broadcast-ethernet-address
+	 interface-names
+	 spawn-ethernet-driver
+	 ethernet-packet-pattern
+	 lookup-ethernet-hwaddr)
+
+(require racket/set)
+(require racket/match)
+(require racket/async-channel)
+
+(require syndicate/monolithic)
+(require syndicate/demand-matcher)
+(require "on-claim.rkt")
+
+(require packet-socket)
+(require bitsyntax)
+
+(require "configuration.rkt")
+(require "dump-bytes.rkt")
+
+(struct ethernet-packet (interface from-wire? source destination ethertype body) #:prefab)
+
+(define zero-ethernet-address (bytes 0 0 0 0 0 0))
+(define broadcast-ethernet-address (bytes 255 255 255 255 255 255))
+
+(define interface-names (raw-interface-names))
+(log-info "Device names: ~a" interface-names)
+
+(define (spawn-ethernet-driver)
+  (spawn-demand-matcher (observe (ethernet-packet (ethernet-interface (?!) ?) #t ? ? ? ?))
+                        (ethernet-interface (?!) ?)
+			spawn-interface-tap))
+
+(define (spawn-interface-tap interface-name)
+  (define h (raw-interface-open interface-name))
+  (define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
+  (cond
+   [(not h)
+    (log-error "ethernet: Couldn't open interface ~v" interface-name)
+    '()]
+   [else
+    (log-info "Opened interface ~a, yielding handle ~v" interface-name h)
+    (define control-ch (make-async-channel))
+    (thread (lambda () (interface-packet-read-loop interface h control-ch)))
+    (actor (lambda (e h)
+	     (match e
+               [(scn g)
+		(if (trie-empty? g)
+		    (begin (async-channel-put control-ch 'quit)
+                           (quit))
+		    (begin (async-channel-put control-ch 'unblock)
+			   #f))]
+	       [(message (inbound (? ethernet-packet? p)))
+		;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
+		;; 	  (ethernet-interface-name (ethernet-packet-interface p))
+		;; 	  (pretty-bytes (ethernet-packet-source p))
+		;; 	  (pretty-bytes (ethernet-packet-destination p))
+		;; 	  (number->string (ethernet-packet-ethertype p) 16))
+		;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
+		(transition h (message p))]
+	       [(message (? ethernet-packet? p))
+		;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
+		;; 	  (ethernet-interface-name (ethernet-packet-interface p))
+		;; 	  (pretty-bytes (ethernet-packet-source p))
+		;; 	  (pretty-bytes (ethernet-packet-destination p))
+		;; 	  (number->string (ethernet-packet-ethertype p) 16))
+		;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
+		(raw-interface-write h (encode-ethernet-packet p))
+		#f]
+	       [_ #f]))
+	   h
+           (scn/union (assertion interface)
+                      (subscription (ethernet-packet interface #f ? ? ? ?))
+                      (subscription (observe (ethernet-packet interface #t ? ? ? ?)))
+                      (subscription (inbound (ethernet-packet interface #t ? ? ? ?)))))]))
+
+(define (interface-packet-read-loop interface h control-ch)
+  (define (blocked)
+    (match (async-channel-get control-ch)
+      ['unblock (unblocked)]
+      ['quit (void)]))
+  (define (unblocked)
+    (match (async-channel-try-get control-ch)
+      ['unblock (unblocked)]
+      ['quit (void)]
+      [#f
+       (define p (raw-interface-read h))
+       (define decoded (decode-ethernet-packet interface p))
+       (when decoded (send-ground-message decoded))
+       (unblocked)]))
+  (blocked)
+  (raw-interface-close h))
+
+(define (decode-ethernet-packet interface p)
+  (bit-string-case p
+    ([ (destination :: binary bytes 6)
+       (source :: binary bytes 6)
+       (ethertype :: integer bytes 2)
+       (body :: binary) ]
+     (ethernet-packet interface
+		      #t
+		      (bit-string->bytes source)
+		      (bit-string->bytes destination)
+		      ethertype
+		      (bit-string->bytes body)))
+    (else #f)))
+
+(define (encode-ethernet-packet p)
+  (match-define (ethernet-packet _ _ source destination ethertype body) p)
+  (bit-string->bytes
+   (bit-string (destination :: binary bytes 6)
+	       (source :: binary bytes 6)
+	       (ethertype :: integer bytes 2)
+	       (body :: binary))))
+
+(define (ethernet-packet-pattern interface-name from-wire? ethertype)
+  (ethernet-packet (ethernet-interface interface-name ?) from-wire? ? ? ethertype ?))
+
+(define (lookup-ethernet-hwaddr base-interests interface-name k)
+  (on-claim #:timeout-msec 5000
+            #:on-timeout (lambda ()
+                           (log-info "Lookup of ethernet interface ~v failed" interface-name)
+                           '())
+            (lambda (_g hwaddrss)
+              (and (not (set-empty? hwaddrss))
+                   (let ((hwaddr (car (set-first hwaddrss))))
+                     (k hwaddr))))
+            base-interests
+            (ethernet-interface interface-name (?!))))

examples/netstack/monolithic-lowlevel/fetchurl.rkt

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

examples/netstack/monolithic-lowlevel/ip.rkt

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

examples/netstack/monolithic-lowlevel/main.rkt

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

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

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

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

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

examples/netstack/monolithic-lowlevel/tcp.rkt

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

examples/netstack/monolithic-lowlevel/udp.rkt

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

examples/operational-transformation/.gitignore

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

examples/operational-transformation/README.md

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

examples/operational-transformation/syndicate-multiserver.rkt

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

examples/operational-transformation/syndicate-server.rkt

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

examples/platformer/.gitignore

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

examples/platformer/hll-main.rkt

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

examples/platformer/info.rkt

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

examples/platformer/sounds/_readme_and_license.txt

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

examples/webchat/NOTES.md

@@ -0,0 +1,38 @@
+## 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

@@ -0,0 +1,49 @@
+<?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

@@ -0,0 +1 @@
+"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);