fixups to get tests passing

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

README.md

@@ -47,6 +47,19 @@ This repository contains
  - a sketch of a Haskell implementation of the core routing structures
    of Syndicate in `hs/`
 
-## Copyright
+## Copyright and License
 
-Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014, 2015, 2016.
+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/>.

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/incremental-highlevel/Makefile

@@ -5,3 +5,8 @@ run:
 
 clean:
 	find . -name compiled -type d | xargs rm -rf
+	rm -f cpingresp
+
+cpingresp: cpingresp.c
+	$(CC) -o $@ $<
+	sudo setcap cap_net_raw+p+i+e $@

examples/netstack/incremental-highlevel/arp.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 ;; ARP protocol, http://tools.ietf.org/html/rfc826
 ;; Only does ARP-over-ethernet.
 
@@ -29,8 +29,8 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (spawn-arp-driver)
-  (actor #:name 'arp-driver
-         (during/actor (arp-interface $interface-name)
+  (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))

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

@@ -1,20 +1,21 @@
-#lang syndicate/actor
+#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")
 
-(actor
+(spawn
  (match (gethostname)
-   ["skip"
-    (assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0"))
-    (assert (host-route (bytes 192 168 1 222) 24 "en0"))]
-   [(or "hop" "walk")
-    (assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0"))
-    (assert (host-route (bytes 192 168 1 222) 24 "wlan0"))]
    ["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
-    (error 'demo-config "No setup for hostname ~a" other)]))
+   [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/ethernet.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 ;; Ethernet driver
 
 (provide (struct-out ethernet-packet)
@@ -29,8 +29,8 @@
 (log-info "Device names: ~a" interface-names)
 
 (define (spawn-ethernet-driver)
-  (actor #:name 'ethernet-driver
-   (during/actor
+  (spawn #:name 'ethernet-driver
+   (during/spawn
     (observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _))
     #:name (list 'ethernet-interface interface-name)
 
@@ -46,7 +46,7 @@
 
     (on-start (flush!) ;; ensure all subscriptions are in place
               (async-channel-put control-ch 'unblock)
-              (actor #:name (list 'ethernet-interface-quit-monitor interface-name)
+              (spawn #:name (list 'ethernet-interface-quit-monitor interface-name)
                      (on (retracted interface)
                          (async-channel-put control-ch 'quit))))
 

examples/netstack/incremental-highlevel/fetchurl.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 
 (require/activate syndicate/drivers/timer)
 (require/activate "ethernet.rkt")

examples/netstack/incremental-highlevel/ip.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 
 (provide (struct-out ip-packet)
 	 ip-address->hostname
@@ -57,15 +57,15 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (spawn-ip-driver)
-  (actor #:name 'ip-driver
-   (during/actor (host-route $my-address $netmask $interface-name)
+  (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/actor (gateway-route $network $netmask $gateway-addr $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/actor (net-route $network-addr $netmask $link)
+   (during/spawn (net-route $network-addr $netmask $link)
                  (assert (route-up (net-route network-addr netmask link)))
                  (do-net-route network-addr netmask link))))
 
@@ -176,20 +176,22 @@
       (when (and (not (equal? (ip-packet-source-interface p) interface-name))
                  (ip-address-in-subnet? destination network netmask))
         (define timer-id (gensym 'ippkt))
-        (react (on-start (send! (set-timer timer-id 5000 'relative)))
+        ;; 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)))
+                 (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))))))))
+                 (send! (ethernet-packet interface
+                                         #f
+                                         (ethernet-interface-hwaddr interface)
+                                         destination-hwaddr
+                                         IPv4-ethertype
+                                         (format-ip-packet p))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

examples/netstack/incremental-highlevel/main.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 
 (require syndicate/protocol/advertise)
 
@@ -19,7 +19,7 @@
   (struct present (who) #:prefab)
 
   (define (spawn-session them us)
-    (actor (define (send-to-remote fmt . vs)
+    (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)
@@ -41,47 +41,51 @@
            (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
-             (define us (tcp-listener 5999))
-             (forever (assert (outbound (advertise (observe (tcp-channel _ us _)))))
-                      (on (asserted (inbound (advertise (tcp-channel $them us _))))
-                          (spawn-session them us)))))
+             (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)))
-  (actor #:name 'udp-echo-program
+  (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
-   (actor #:name 'webserver-counter
+   (spawn #:name 'webserver-counter
           (field [counter 0])
           (on (message 'bump)
               (send! `(counter ,(counter)))
               (counter (+ (counter) 1))))
 
-   (forever (define us (tcp-listener 80))
-            (assert (outbound (advertise (observe (tcp-channel _ us _)))))
-            (during/actor (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
-                          #:name (list 'webserver-session them)
-                          (log-info "Got connection from ~v" them)
-                          (field [done? #f])
-                          (stop-when (rising-edge (done?)))
-                          (assert (outbound (advertise (tcp-channel us them _))))
-                          (on (message (inbound (tcp-channel them us _)))) ;; ignore input
+   (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\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)))
-                              (done? #t))))))
+            (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

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 ;; UDP/TCP port allocator
 
 (provide spawn-port-allocator
@@ -13,7 +13,7 @@
 (struct port-allocation-reply (reqid port) #:prefab)
 
 (define (spawn-port-allocator allocator-type query-used-ports)
-  (actor #:name (list 'port-allocator allocator-type)
+  (spawn #:name (list 'port-allocator allocator-type)
          (define local-ips (query-local-ip-addresses))
          (define used-ports (query-used-ports))
 

examples/netstack/incremental-highlevel/tcp.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 
 (provide (struct-out tcp-address)
 	 (struct-out tcp-handle)
@@ -13,10 +13,14 @@
 (require "dump-bytes.rkt")
 (require "checksum.rkt")
 
-(require/activate syndicate/drivers/timer)
+(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
@@ -46,14 +50,27 @@
 ;; (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)
-  (actor #:name 'tcp-inbound-driver
-   (during/actor (advertise (observe (tcp-channel _ ($ server-addr (tcp-listener _)) _)))
+  (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))
@@ -61,7 +78,7 @@
                                                        ($ local-addr (tcp-address _ port))
                                                        _)))
                      (spawn-relay server-addr remote-addr local-addr))))
-  (actor #:name 'tcp-outbound-driver
+  (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 _ _))
@@ -92,7 +109,7 @@
 (define (spawn-relay local-user-addr remote-addr local-tcp-addr)
   (define timer-name (list 'spawn-relay local-tcp-addr remote-addr))
 
-  (actor #:name (list 'tcp-relay local-user-addr remote-addr local-tcp-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 _)))
@@ -100,10 +117,9 @@
    (field [local-peer-present? #f]
           [remote-peer-present? #f])
 
-   (on-start (send! (set-timer timer-name relay-peer-wait-time-msec 'relative)))
-   (on (message (timer-expired timer-name _))
-       (when (not (and (local-peer-present?) (remote-peer-present?)))
-         (error 'spawn-relay "TCP relay process timed out waiting for peer")))
+   (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))
@@ -125,7 +141,7 @@
 (define PROTOCOL-TCP 6)
 
 (define (spawn-kernel-tcp-driver)
-  (actor #:name 'kernel-tcp-driver
+  (spawn #:name 'kernel-tcp-driver
    (define local-ips (query-local-ip-addresses))
 
    (define active-state-vectors
@@ -165,16 +181,6 @@
           (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) ]
@@ -189,18 +195,19 @@
                                        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))
-               ;; TODO: get packet to the new state-vector process somehow
                (send! packet)))
             (else #f))))
        (else #f)))
 
    (begin/dataflow
-     (log-info "SCN yielded statevecs ~v and local-ips ~v"
-               (active-state-vectors)
-               (local-ips)))
+     (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
@@ -215,15 +222,7 @@
                                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)
+     (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)
@@ -264,16 +263,111 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 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 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
@@ -290,39 +384,97 @@
       (- 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))
-  (define (timer-name kind) (list 'tcp-timer kind src dst))
 
-  (actor
+  (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
-          [most-recent-time (current-inexact-milliseconds)]
-          ;; ^ updated by timer expiry; a field, to trigger quit checks
-          [quit-because-reset? #f])
 
-   (let ()
-     (local-require (submod syndicate/actor priorities))
-     (on-event #:priority *query-priority*
-               [_ (most-recent-time (current-inexact-milliseconds))]))
+          ;; 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))
@@ -333,7 +485,6 @@
      (inbound (struct-copy buffer (inbound) [seqn seqn])))
 
    (define (incorporate-segment! data)
-     ;; (log-info "GOT INBOUND STUFF TO DELIVER ~v" data)
      (when (not (buffer-finished? (inbound)))
        (inbound (buffer-push (inbound) data))))
 
@@ -349,158 +500,263 @@
    ;; (Setof Symbol) -> Void
    (define (check-fin! flags)
      (define b (inbound))
-     (unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
-       (error 'check-fin "Nonempty inbound buffer"))
-     (when (set-member? flags 'fin)
-       (log-info "Closing inbound stream.")
-       (inbound (struct-copy buffer b
-                  [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
-                  [finished? #t]))))
+     (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))
-              (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))
+              (ackn (seq-min ackn (high-water-mark)))
+              (ackn (seq-max ackn base))
               (dist (seq- ackn base)))
-         (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
          (user-timeout-base-time (current-inexact-milliseconds))
-         (outbound (struct-copy buffer b [data remaining-data] [seqn ackn]))
-         (syn-acked? (or (syn-acked?) (positive? dist))))))
+         (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))))
 
-   ;; (Option SeqNum) -> Void
-   (define (send-outbound! old-ackn)
-     (define b (outbound))
-     (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 (syn-acked?) (buffer-window b) 1)
-                               ;; ^ can only send SYN until SYN is acked
-                               pending-byte-count))
-     (define segment-offset (if (syn-acked?) 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))
-     (define flags (set))
-     (when ackn
-       (set! flags (set-add flags 'ack)))
-     (when (not (syn-acked?))
-       (set! flags (set-add flags 'syn)))
-     (when (and (buffer-finished? b)
-                (syn-acked?)
-                (= segment-size pending-byte-count)
-                (not (all-output-acknowledged?))) ;; 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 (inbound))
-                                 (bit-string-byte-count (buffer-data (inbound)))))))
-     (unless (and (equal? ackn old-ackn)
-                  (syn-acked?)
-                  (not (set-member? flags 'fin))
-                  (zero? (bit-string-byte-count chunk)))
-       (local-require racket/pretty)
-       (pretty-write `(send-outbound (old-ackn ,old-ackn)
-                                     (flags ,flags)))
-       (flush-output)
-       (send! (tcp-packet #f dst-ip dst-port src-ip src-port
-                          (buffer-seqn b)
-                          (or ackn 0)
-                          flags
-                          window
-                          #""
-                          chunk))))
-
-   (define (bump-peer-activity-time!)
-     (latest-peer-activity-time (current-inexact-milliseconds)))
-
-   ;; Number -> Boolean
-   (define (heard-from-peer-within-msec? msec)
-     (<= (- (most-recent-time) (latest-peer-activity-time)) msec))
-
-   (define (user-timeout-expired?)
-     (and (not (all-output-acknowledged?))
-          (> (- (most-recent-time) (user-timeout-base-time))
-             user-timeout-msec)))
-
-   (define (send-set-transmit-check-timer!)
-     (send! (set-timer (timer-name 'transmit-check)
-                       transmit-check-interval-msec
-                       'relative)))
-
-   (define (reset! seqn ackn)
-     (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-because-reset? #t)
-     (send! (tcp-packet #f dst-ip dst-port src-ip src-port
-                        seqn
-                        ackn
-                        (set 'ack 'rst)
-                        0
-                        #""
-                        #"")))
-
    (define (close-outbound-stream!)
      (define b (outbound))
      (when (not (buffer-finished? b))
        (outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte
-                   [finished? #t]))))
+                   [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 _)))
 
-   (stop-when
-    (rising-edge
-     (and (buffer-finished? (outbound))
-          (buffer-finished? (inbound))
-          (all-output-acknowledged?)
-          (not (heard-from-peer-within-msec? (* 2 1000 maximum-segment-lifetime-sec)))))
+   (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
-    (rising-edge (user-timeout-expired?))
+   (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-info "TCP_USER_TIMEOUT fired."))
-
-   (stop-when (rising-edge (quit-because-reset?)))
+    (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-info "Closing outbound stream.")
-                   (close-outbound-stream!)
-                   (send-outbound! (buffer-seqn (inbound)))))
+                   (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 old-ackn (buffer-seqn (inbound)))
        (define expected (next-expected-seqn))
        (define is-syn? (set-member? flags 'syn))
        (define is-fin? (set-member? flags 'fin))
        (cond
-         [(set-member? flags 'rst) (quit-because-reset? #t)]
+         [(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...
@@ -513,38 +769,28 @@
           (cond
             [(not expected) ;; haven't seen syn yet, but we know this is it
              (set-inbound-seqn! (seq+ seqn 1))
-             (incorporate-segment! data)]
+             (incorporate-segment! data)
+             (trigger-ack!)]
             [(= expected seqn)
-             (incorporate-segment! data)]
-            [else (void)])
+             (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)
-          (send-outbound! old-ackn)
-          (bump-peer-activity-time!)]))
+          (latest-peer-activity-time (current-inexact-milliseconds))]))
 
    (on (message (tcp-channel dst src $bs))
-       (define old-ackn (buffer-seqn (inbound)))
-       ;; (log-info "GOT MORE STUFF TO DELIVER ~v" 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))
-       (send-outbound! old-ackn))
-
-   (on-start (send-set-transmit-check-timer!))
-   (on (message (timer-expired (timer-name 'transmit-check) _))
-       (define old-ackn (buffer-seqn (inbound)))
-       ;; 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.
-       (send-set-transmit-check-timer!)
-       (send-outbound! old-ackn))))
+       (outbound (buffer-push (outbound) bs)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

examples/netstack/incremental-highlevel/udp.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 
 (provide (struct-out udp-remote-address)
 	 (struct-out udp-handle)
@@ -50,18 +50,18 @@
 (define (spawn-udp-driver)
   (spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p)))
   (spawn-kernel-udp-driver)
-  (actor #:name '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 _)) _)))
-       (actor #:name (list 'udp-transient h)
+       (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)
-  (actor #:name (list '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 ? ?))
@@ -97,7 +97,7 @@
 (define PROTOCOL-UDP 17)
 
 (define (spawn-kernel-udp-driver)
-  (actor #:name 'kernel-udp-driver
+  (spawn #:name 'kernel-udp-driver
          (assert (advertise (ip-packet #f _ _ PROTOCOL-UDP _ _)))
 
          (define local-ips (query-local-ip-addresses))

examples/netstack/monolithic-lowlevel/arp.rkt

@@ -215,7 +215,7 @@
                                            (cache-key-address q)))))))
 
   (list (set-wakeup-alarm)
-	(spawn (lambda (e s)
+	(actor (lambda (e s)
 		 ;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s)
 		 (match e
 		   [(scn g)

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

@@ -4,22 +4,23 @@
 (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)
-  (spawn (lambda (e s) #f)
+  (actor (lambda (e s) #f)
          (void)
          (match (gethostname)
-           ["skip"
-            (scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0"))
-                       (assertion (host-route (bytes 192 168 1 222) 24 "en0")))]
-           [(or "hop" "walk")
-            (scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0"))
-                       (assertion (host-route (bytes 192 168 1 222) 24 "wlan0")))]
            ["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")))]
-           [else
-            (error 'spawn-demo-config "No setup for hostname ~a" (gethostname))])))
+           [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/ethernet.rkt

@@ -47,7 +47,7 @@
     (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)))
-    (spawn (lambda (e h)
+    (actor (lambda (e h)
 	     (match e
                [(scn g)
 		(if (trie-empty? g)

examples/netstack/monolithic-lowlevel/ip.rkt

@@ -83,7 +83,7 @@
 			    network-addr
 			    netmask
 			    interface-name))
-   (spawn (lambda (e s)
+   (actor (lambda (e s)
 	    (match e
 	      [(scn (? trie-empty?)) (quit)]
 	      [(message (ip-packet _ peer-address _ _ _ body))
@@ -143,7 +143,7 @@
       (and (positive? msk)
 	   (ip-address-in-subnet? addr net msk))))
 
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
 	   (match e
 	     [(scn g)
 	      (define host-ips+netmasks (trie-project/set #:take 2 g host-route-projector))
@@ -202,7 +202,7 @@
 ;; Normal IP route
 
 (define (spawn-normal-ip-route the-route network netmask interface-name)
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
 	   (match e
 	     [(scn (? trie-empty?)) (quit)]
 	     [(message (ethernet-packet _ _ _ _ _ body))

examples/netstack/monolithic-lowlevel/main.rkt

@@ -34,7 +34,7 @@
     (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)
-          (spawn
+          (actor
            (lambda (e peers)
              (match e
                [(message (inbound (tcp-channel _ _ bs)))
@@ -61,14 +61,14 @@
             (advertisement (inbound (tcp-channel us them ?))) ;; we will write to remote client
             ))))
 
-  (spawn-dataspace
+  (dataspace-actor
    (spawn-demand-matcher (inbound (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?)))
                          (inbound (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?)))
                          spawn-session))
   )
 
 (let ()
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
 	   (match e
 	     [(message (udp-packet src dst body))
 	      (log-info "Got packet from ~v: ~v" src body)
@@ -84,7 +84,7 @@
   (define (spawn-session them us)
     (list
      (message 'bump)
-     (spawn (lambda (e s)
+     (actor (lambda (e s)
 	      (match e
 		[(message `(counter ,counter))
 		 (define response
@@ -105,8 +105,8 @@
                        (subscription (inbound (advertise (tcp-channel them us ?))))
                        (advertisement (inbound (tcp-channel us them ?)))))))
 
-  (spawn-dataspace
-   (spawn (lambda (e counter)
+  (dataspace-actor
+   (actor (lambda (e counter)
 	    (match e
 	      [(message 'bump)
 	       (transition (+ counter 1) (message `(counter ,counter)))]

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

@@ -10,14 +10,14 @@
 ;; -> Action
 ;; Spawns a process that observes the given projections. Any time the
 ;; environment's interests change in a relevant way, calls
-;; check-and-maybe-spawn-fn with the aggregate interests and the
-;; projection results. If check-and-maybe-spawn-fn returns #f,
+;; 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-spawn-fn
+                  check-and-maybe-actor-fn
                   base-interests
                   . projections)
   (define timer-id (gensym 'on-claim))
@@ -27,18 +27,18 @@
        (define projection-results
          (map (lambda (p) (trie-project/set #:take (projection-arity p) new-aggregate p))
               projections))
-       (define maybe-spawn (apply check-and-maybe-spawn-fn
+       (define maybe-actor (apply check-and-maybe-actor-fn
                                   new-aggregate
                                   projection-results))
-       (if maybe-spawn
-           (quit maybe-spawn)
+       (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)))
-   (spawn #:name name
+   (actor #:name name
           on-claim-handler
           (void)
           (scn/union base-interests

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

@@ -14,7 +14,7 @@
 (struct port-allocator-state (used-ports local-ips) #:transparent)
 
 (define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports)
-  (spawn #:name (string->symbol (format "port-allocator:~a" allocator-type))
+  (actor #:name (string->symbol (format "port-allocator:~a" allocator-type))
          (lambda (e s)
 	   (match e
 	     [(scn g)

examples/netstack/monolithic-lowlevel/tcp.rkt

@@ -59,7 +59,7 @@
 				(match-define (tcp-listener port) server-addr)
 				;; TODO: have listener shut down once user-level listener does
                                 (list
-                                 (spawn #:name (string->symbol
+                                 (actor #:name (string->symbol
                                                 (format "tcp-listener-port-reservation:~a" port))
                                         (lambda (e s) #f)
                                         (void)
@@ -122,7 +122,7 @@
   (define remote-peer-traffic (?! (advertise (tcp-channel remote-addr local-tcp-addr ?))))
   (list
    (message (set-timer timer-name relay-peer-wait-time-msec 'relative))
-   (spawn #:name (string->symbol (format "tcp-relay:~v:~v:~v"
+   (actor #:name (string->symbol (format "tcp-relay:~v:~v:~v"
                                          local-user-addr
                                          remote-addr
                                          local-tcp-addr))
@@ -294,7 +294,7 @@
     (transition s (message (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
                                       (ip-checksum 16 payload #:pseudo-header pseudo-header)))))
 
-  (spawn #:name 'kernel-tcp-driver
+  (actor #:name 'kernel-tcp-driver
          (lambda (e s)
 	   (match e
 	     [(scn g)
@@ -655,7 +655,7 @@
                              (current-inexact-milliseconds)
 			     #f
 			     #f)))
-     (spawn #:name
+     (actor #:name
             (string->symbol (format "tcp-state-vector:~a:~a:~a:~a"
                                     (ip-address->hostname src-ip)
                                     src-port

examples/netstack/monolithic-lowlevel/udp.rkt

@@ -92,7 +92,7 @@
                            (subscription (udp-datagram ? ? ip local-port ?))
                            (advertisement (udp-datagram ip local-port ? ? ?)))))
 
-  (spawn (lambda (e local-ips)
+  (actor (lambda (e local-ips)
 	   (match e
 	     [(scn g)
 	      (define new-local-ips (gestalt->local-ip-addresses g))
@@ -124,7 +124,7 @@
 (define PROTOCOL-UDP 17)
 
 (define (spawn-kernel-udp-driver)
-  (spawn (lambda (e local-ips)
+  (actor (lambda (e local-ips)
 	   (match e
 	     [(scn g)
 	      (transition (gestalt->local-ip-addresses g) '())]

examples/operational-transformation/syndicate-multiserver.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 
 (require racket/file)
 (require racket/serialize)
@@ -18,11 +18,11 @@
 (define cmdline-port (make-parameter 5889))
 (define cmdline-filenames (make-parameter '()))
 
-(actor* (for [(filename (cmdline-filenames))]
+(spawn* (for [(filename (cmdline-filenames))]
           (run-one-server filename)))
 
 (define (run-one-server filename)
-  (actor (field [state (make-server (simple-document
+  (spawn (field [state (make-server (simple-document
                                      (if (file-exists? filename)
                                          (begin (log-info "loading ~v" filename)
                                                 (file->string filename))
@@ -51,10 +51,10 @@
              (define sp (extract-operation (state)))
              (when sp (send! (accepted-op filename sp))))))
 
-(actor (define s (tcp-listener (cmdline-port)))
+(spawn (define s (tcp-listener (cmdline-port)))
        (on-start (log-info "listening on port ~v" (cmdline-port)))
        (assert (advertise (observe (tcp-channel _ s _))))
-       (during/actor (advertise (tcp-channel $c 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))

examples/operational-transformation/syndicate-server.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 
 (require racket/file)
 (require racket/serialize)
@@ -16,7 +16,7 @@
 (define cmdline-port (make-parameter 5888))
 (define cmdline-filename (make-parameter "info.rkt"))
 
-(actor (field [state (make-server (simple-document
+(spawn (field [state (make-server (simple-document
                                    (if (file-exists? (cmdline-filename))
                                        (begin (log-info "loading ~v" (cmdline-filename))
                                               (file->string (cmdline-filename)))
@@ -45,10 +45,10 @@
            (define sp (extract-operation (state)))
            (when sp (send! (accepted-op sp)))))
 
-(actor (define s (tcp-listener (cmdline-port)))
+(spawn (define s (tcp-listener (cmdline-port)))
        (on-start (log-info "listening on port ~v" (cmdline-port)))
        (assert (advertise (observe (tcp-channel _ s _))))
-       (during/actor (advertise (tcp-channel $c 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))

examples/platformer/hll-main.rkt

@@ -1,4 +1,4 @@
-#lang syndicate/actor
+#lang syndicate
 
 (require 2htdp/image)
 (require 2htdp/planetcute)
@@ -302,7 +302,7 @@
 ;; SceneManager
 
 (define (spawn-scene-manager)
-  (actor #:name '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))
@@ -337,7 +337,7 @@
 ;; ScoreKeeper
 
 (define (spawn-score-keeper)
-  (actor #:name 'score-keeper
+  (spawn #:name 'score-keeper
          (field [score 0])
          (assert (current-score (score)))
          (assert (outbound
@@ -356,7 +356,7 @@
 (define gravity 0.004)
 
 (define (spawn-physics-engine)
-  (actor #:name 'physics-engine
+  (spawn #:name 'physics-engine
    (field [configs (hash)]
           [previous-positions (hash)]
           [previous-velocities (hash)]
@@ -535,7 +535,7 @@
 (define planetcute-scale 1/2)
 
 (define (spawn-player-avatar initial-focus-x initial-focus-y)
-  (actor #:name 'player-avatar
+  (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))
 
@@ -550,7 +550,7 @@
 
    (field [hit-points 1])
    (assert (health player-id (hit-points)))
-   (stop-when (rising-edge (<= (hit-points) 0)))
+   (stop-when-true (<= (hit-points) 0))
    (on (message (damage player-id $amount))
        (hit-points (- (hit-points) amount)))
 
@@ -567,7 +567,7 @@
 ;; Ground Block
 
 (define (spawn-ground-block top-left size #:color [color "purple"])
-  (actor #:name (list 'ground-block top-left size color)
+  (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))
@@ -589,7 +589,7 @@
   (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))
 
-  (actor #:name (list 'goal-piece 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
@@ -604,7 +604,7 @@
 (define (spawn-enemy initial-x initial-y range-lo range-hi
                      #:speed [speed 0.2]
                      #:facing [initial-facing 'right])
-  (actor #:name (list 'enemy initial-x initial-y initial-facing)
+  (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))]))
@@ -624,9 +624,9 @@
                               [(> (+ left width) range-hi) 'left]
                               [else (facing)]))))
 
-   (stop-when (rising-edge (and (current-level-size)
-                                (> (vector-ref (pos) 1)
-                                   (vector-ref (current-level-size) 1)))))
+   (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
@@ -647,7 +647,7 @@
 (define (spawn-display-controller level-size-vec)
   (match-define (vector level-width level-height) level-size-vec)
 
-  (actor #:name 'display-controller
+  (spawn #:name 'display-controller
    (field [offset-pos (vector 0 0)])
    (assert (outbound* 2 (scroll-offset (offset-pos))))
    (assert (level-size level-size-vec))
@@ -671,23 +671,23 @@
 ;; kills the dataspace.
 
 (define (wait-for-level-termination)
-  (react/suspend (done)
-                 (assert (outbound (level-running)))
-                 (stop-when (retracted (game-piece-configuration player-id _ _ _))
-                            (log-info "Player died! Terminating level.")
-                            (play-sound-sequence 270328)
-                            (done))
-                 (stop-when (message (inbound (level-completed)))
-                            (log-info "Level completed! Terminating level.")
-                            (play-sound-sequence 270330)
-                            (send! (outbound (add-to-score 100)))
-                            (done))))
+  (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)
-  (actor #:name 'standalone-assertions
+  (spawn #:name 'standalone-assertions
          (on-start (patch! (patch-seq* patches)))))
 
 (define (spawn-background-image level-size scene)
@@ -778,7 +778,7 @@
                                         message))))))
 
 (define (spawn-level-spawner starting-level)
-  (actor #:name 'level-spawner
+  (spawn #:name 'level-spawner
          (field [current-level starting-level]
                 [level-complete? #f])
 
@@ -816,5 +816,4 @@
 (spawn-keyboard-integrator)
 (spawn-scene-manager)
 (dataspace (spawn-score-keeper)
-           (spawn-level-spawner 0)
-           (forever))
+           (spawn-level-spawner 0))

examples/platformer/lll-main.rkt

@@ -335,7 +335,7 @@
                                               p
                                               (?! (on-screen-display ? ? ?)))]))
 
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
            (match e
              [(? patch? p)
               (let* ((s (update-window-size s p))
@@ -381,7 +381,7 @@
     (define i (text (format "Score: ~a" new-score) 24 "white"))
     (patch-seq (retract (outbound (on-screen-display ? ? ?)))
                (assert (outbound (on-screen-display -150 10 (seal i))))))
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
            (match e
              [(message (add-to-score delta))
               (define new-score (+ s delta))
@@ -603,7 +603,7 @@
          (play-sound-sequence 270318)
          ((update-piece g pos (v+ pos (vector 0 -1)) jump-vel) s)))
 
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
            (match e
              [(? patch? p)
               (sequence-transitions (transition s '())
@@ -679,7 +679,7 @@
                   (patch-seq (retract (impulse player-id ?))
                              (assert (impulse player-id (vector h-impulse 0)))))))
 
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
            (match e
              [(? patch? p)
               (sequence-transitions (transition s '())
@@ -720,7 +720,7 @@
   (match-define (vector w h) size)
   (define block-id (gensym 'ground-block))
   (define block-pict (rectangle w h "solid" color))
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
            (match e
              [_ #f]))
          (void)
@@ -742,7 +742,7 @@
   (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 (lambda (e s)
+  (actor (lambda (e s)
            (match e
              [(? patch/added?) (transition s (message (outbound (level-completed))))]
              [_ #f]))
@@ -824,7 +824,7 @@
                (quit (list damage-actions (message (outbound (add-to-score 1))))))
         (transition s damage-actions)))
 
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
            (match e
              [(? patch? p)
               (sequence-transitions (transition s '())
@@ -874,7 +874,7 @@
                              (patch-seq (retract (outbound* 2 (scroll-offset ?)))
                                         (assert (outbound* 2 (scroll-offset offset-pos))))))))))
 
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
            (match e
              [(? patch? p)
               (sequence-transitions (transition s '())
@@ -893,7 +893,7 @@
 ;; kills the dataspace.
 
 (define (spawn-level-termination-monitor)
-  (spawn (lambda (e s)
+  (actor (lambda (e s)
            (match e
              [(? patch/removed?)
               (log-info "Player died! Terminating level.")
@@ -914,7 +914,7 @@
 ;; LevelSpawner
 
 (define (spawn-standalone-assertions . patches)
-  (spawn (lambda (e s) #f)
+  (actor (lambda (e s) #f)
          (void)
          patches))
 
@@ -942,7 +942,7 @@
                      #:level-size [level-size-vec (vector 4000 2000)]
                      #:scene [scene grassland-backdrop]
                      . actions)
-  (spawn-dataspace
+  (dataspace-actor
    (and scene (spawn-background-image level-size-vec scene))
    (spawn-display-controller level-size-vec)
    (spawn-physics-engine)
@@ -1005,7 +1005,7 @@
 (define (spawn-level-spawner starting-level)
   (struct level-spawner-state (current-level level-complete?) #:prefab)
 
-  (list (spawn (lambda (e s)
+  (list (actor (lambda (e s)
                  (match-define (level-spawner-state current-level level-complete?) s)
                  (match e
                    [(? patch/removed?)
@@ -1045,5 +1045,5 @@
 ((2d-dataspace #:width 600 #:height 400)
  (spawn-keyboard-integrator)
  (spawn-scene-manager)
- (spawn-dataspace (spawn-score-keeper)
+ (dataspace-actor (spawn-score-keeper)
                   (spawn-level-spawner 0)))

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

examples/webchat/htdocs/speechbubble-l.svg

@@ -0,0 +1,85 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!-- Created with Inkscape (http://www.inkscape.org/) -->
+
+<svg
+   xmlns:dc="http://purl.org/dc/elements/1.1/"
+   xmlns:cc="http://creativecommons.org/ns#"
+   xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+   xmlns:svg="http://www.w3.org/2000/svg"
+   xmlns="http://www.w3.org/2000/svg"
+   xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
+   xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
+   width="4.5155554mm"
+   height="5.6444445mm"
+   viewBox="0 0 15.999999 20"
+   id="svg2"
+   version="1.1"
+   inkscape:version="0.91 r13725"
+   sodipodi:docname="speechbubble2-l.svg"
+   inkscape:export-filename="/home/tonyg/src/syndicate/examples/webchat/htdocs/speechbubble-l.png"
+   inkscape:export-xdpi="90"
+   inkscape:export-ydpi="90">
+  <defs
+     id="defs4" />
+  <sodipodi:namedview
+     id="base"
+     pagecolor="#ffffff"
+     bordercolor="#666666"
+     borderopacity="1.0"
+     inkscape:pageopacity="0.0"
+     inkscape:pageshadow="2"
+     inkscape:zoom="22.627417"
+     inkscape:cx="2.6426767"
+     inkscape:cy="9.8662922"
+     inkscape:document-units="px"
+     inkscape:current-layer="layer1"
+     showgrid="true"
+     inkscape:window-width="1908"
+     inkscape:window-height="1027"
+     inkscape:window-x="0"
+     inkscape:window-y="28"
+     inkscape:window-maximized="1"
+     inkscape:object-nodes="true"
+     inkscape:snap-bbox="true"
+     inkscape:snap-nodes="false"
+     inkscape:bbox-nodes="true"
+     fit-margin-top="0"
+     fit-margin-left="0"
+     fit-margin-right="0"
+     fit-margin-bottom="0">
+    <inkscape:grid
+       type="xygrid"
+       id="grid4140"
+       originx="0"
+       originy="-4.7244096e-06" />
+  </sodipodi:namedview>
+  <metadata
+     id="metadata7">
+    <rdf:RDF>
+      <cc:Work
+         rdf:about="">
+        <dc:format>image/svg+xml</dc:format>
+        <dc:type
+           rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
+        <dc:title></dc:title>
+      </cc:Work>
+    </rdf:RDF>
+  </metadata>
+  <g
+     inkscape:label="Layer 1"
+     inkscape:groupmode="layer"
+     id="layer1"
+     transform="translate(0,-1032.3622)">
+    <path
+       style="fill:#ffffff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+       d="m 16,1032.3622 -16,10 16,10 z"
+       id="path4138"
+       inkscape:connector-curvature="0"
+       sodipodi:nodetypes="cccc" />
+    <path
+       style="fill:none;fill-opacity:1;fill-rule:evenodd;stroke:#d3d3d3;stroke-width:0.99999994px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+       d="m 23.500001,1028.2643 -22.556417,14.0979 22.556417,14.098 z"
+       id="path4142"
+       inkscape:connector-curvature="0" />
+  </g>
+</svg>

examples/webchat/htdocs/speechbubble-r.svg

@@ -0,0 +1,85 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!-- Created with Inkscape (http://www.inkscape.org/) -->
+
+<svg
+   xmlns:dc="http://purl.org/dc/elements/1.1/"
+   xmlns:cc="http://creativecommons.org/ns#"
+   xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+   xmlns:svg="http://www.w3.org/2000/svg"
+   xmlns="http://www.w3.org/2000/svg"
+   xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
+   xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
+   width="4.5155554mm"
+   height="5.6444445mm"
+   viewBox="0 0 15.999999 20"
+   id="svg2"
+   version="1.1"
+   inkscape:version="0.91 r13725"
+   sodipodi:docname="speechbubble2-r.svg"
+   inkscape:export-filename="/home/tonyg/src/syndicate/examples/webchat/htdocs/speechbubble-r.png"
+   inkscape:export-xdpi="90"
+   inkscape:export-ydpi="90">
+  <defs
+     id="defs4" />
+  <sodipodi:namedview
+     id="base"
+     pagecolor="#ffffff"
+     bordercolor="#666666"
+     borderopacity="1.0"
+     inkscape:pageopacity="0.0"
+     inkscape:pageshadow="2"
+     inkscape:zoom="22.627417"
+     inkscape:cx="2.6426767"
+     inkscape:cy="9.8662922"
+     inkscape:document-units="px"
+     inkscape:current-layer="layer1"
+     showgrid="true"
+     inkscape:window-width="1908"
+     inkscape:window-height="1027"
+     inkscape:window-x="0"
+     inkscape:window-y="28"
+     inkscape:window-maximized="1"
+     inkscape:object-nodes="true"
+     inkscape:snap-bbox="true"
+     inkscape:snap-nodes="false"
+     inkscape:bbox-nodes="true"
+     fit-margin-top="0"
+     fit-margin-left="0"
+     fit-margin-right="0"
+     fit-margin-bottom="0">
+    <inkscape:grid
+       type="xygrid"
+       id="grid4140"
+       originx="0"
+       originy="-4.7244096e-06" />
+  </sodipodi:namedview>
+  <metadata
+     id="metadata7">
+    <rdf:RDF>
+      <cc:Work
+         rdf:about="">
+        <dc:format>image/svg+xml</dc:format>
+        <dc:type
+           rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
+        <dc:title></dc:title>
+      </cc:Work>
+    </rdf:RDF>
+  </metadata>
+  <g
+     inkscape:label="Layer 1"
+     inkscape:groupmode="layer"
+     id="layer1"
+     transform="translate(0,-1032.3622)">
+    <path
+       style="fill:#e8e8ff;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+       d="m 0,1032.3622 16,10 -16,10 z"
+       id="path4138"
+       inkscape:connector-curvature="0"
+       sodipodi:nodetypes="cccc" />
+    <path
+       style="fill:none;fill-opacity:1;fill-rule:evenodd;stroke:#d3d3d3;stroke-width:0.99999994px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+       d="m -7.5000015,1028.2643 22.5564175,14.0979 -22.5564175,14.098 z"
+       id="path4142"
+       inkscape:connector-curvature="0" />
+  </g>
+</svg>

examples/webchat/htdocs/style.css

@@ -0,0 +1,213 @@
+template {
+    display: none !important;
+}
+
+img.avatar {
+    border-radius: 24px;
+}
+
+/* --------------------------------------------------------------------------- */
+
+.main-container {
+    display: flex;
+    height: 100vh;
+    flex-direction: column;
+}
+
+#main-div {
+    flex: 1;
+    overflow: auto;
+}
+
+.column-container {
+    display: flex;
+    flex-direction: column;
+}
+
+.column-fill {
+    flex: 1;
+    overflow: auto;
+}
+
+/* --------------------------------------------------------------------------- */
+
+.alert-count {
+    background: red;
+    color: white;
+    padding: 0em 0.25em;
+    border-radius: 4px;
+}
+
+.hide-zero-count.count0 {
+    display: none;
+}
+
+.show-only-zero-count {
+    display: none;
+}
+.show-only-zero-count.count0 {
+    display: inherit;
+}
+
+.plural.count1 {
+    display: none;
+}
+
+.contact-list-present-false {
+    opacity: 0.3;
+}
+
+.align-right { text-align: right; }
+.align-center { text-align: center; }
+
+.cursor-interactive {
+    cursor: pointer;
+}
+
+.dropdown-marginal {
+    left: -1.1em;
+    display: inline-block;
+    width: 0px;
+    position: relative;
+}
+
+.forcewrap {
+    word-wrap: break-word !important;
+    xhyphens: auto;
+}
+
+.big-icon {
+    font-size: 1.75rem;
+}
+
+.invited-tick {
+    font-size: 2rem;
+    width: 48px;
+    height: 48px;
+    display: inline-block;
+    border-radius: 24px;
+    color: white;
+    background: darkgreen;
+    text-align: center;
+    line-height: 0px;
+}
+
+.invited-tick .icon {
+    position: relative;
+    top: 0.5rem;
+}
+
+.blurb-box {
+}
+
+.float-right { float: right; }
+
+.main-container footer {
+    padding-top: 1rem;
+    text-align: right;
+}
+
+/* --------------------------------------------------------------------------- */
+
+.conversation-control-panel {
+    font-size: 2rem;
+}
+
+.post-backdrop {
+    overflow-y: scroll;
+}
+
+.post {
+    margin: 20px;
+}
+
+.post .post-body {
+    background: white;
+    border: solid #d3d3d3 1px;
+    border-radius: 1.5rem;
+    padding: 1rem;
+    margin: 0 0px;
+    min-height: 60px;
+}
+
+.post p {
+    margin-bottom: 0;
+}
+
+.post.from-me .post-body {
+    background: #e8e8ff;
+    margin-left: 4rem;
+    margin-right: -1px;
+}
+
+.post.to-me .post-body {
+    margin-left: -1px;
+    margin-right: 4rem;
+}
+
+.post.from-me:after {
+    content: url('/speechbubble-r.png');
+    position: relative;
+    /* left: 100%; */
+    right: -100%;
+    top: -40px;
+    height: 0px;
+    width: 0px;
+    display: block;
+}
+
+.post.to-me:after {
+    content: url('/speechbubble-l.png');
+    position: relative;
+    left: -16px;
+    top: -40px;
+    height: 0px;
+    width: 0px;
+    display: block;
+}
+
+.post-date {
+    float: right;
+    height: 0.25em;
+    display: block;
+    font-size: 0.75rem;
+    padding-right: 0.5em;
+}
+
+.post-author {
+    /* font-weight: bold; */
+    font-size: 0.75rem;
+    position: relative;
+    top: -0.75em;
+    height: 0.75em;
+}
+
+.post-item {
+}
+
+.post-item-draft {
+    /* background: #e8e8ff; */
+    background: white;
+    border: solid #d3d3d3 1px;
+    border-radius: 1.5rem;
+    padding: 1rem;
+    margin: 1rem 0 0 0;
+}
+
+.post-item-draft .close-draft {
+    float: right;
+}
+
+.post-item-image {
+    max-width: 100%;
+    max-height: 50vh;
+}
+
+.post-item-draft .post-item-image {
+    max-width: 80%;
+    max-height: 30vh;
+}
+
+.post-item .post-item-body-container table.application-octet-stream td {
+    text-align: center;
+}

examples/webchat/htdocs/templates/contact-entry.html

@@ -0,0 +1,22 @@
+<div class="col-xs-12 col-md-6 col-lg-4 p-1 dropdown">
+  <div class="cursor-interactive contact-list-present-{{isPresent}} dropdown-toggle" data-toggle="dropdown">
+    <img class="avatar" src="{{avatar}}">
+    <span class="forcewrap">{{email}}</span>
+    {{#pendingContactRequest}}(pending){{/pendingContactRequest}}
+  </div>
+  <div class="dropdown-menu pt-0 w-100">
+    <img src="{{avatar}}&s=512" class="w-100">
+    <div class="my-1 mx-2">
+      <h3 class="forcewrap">{{email}}</h3>
+      <!-- <p> -->
+      <!--   It is a long established fact that a reader will be distracted -->
+      <!--   by the readable content of a page when looking at its layout. -->
+      <!-- </p> -->
+      <!-- <hr> -->
+      <!-- <p>Rest of text.</p> -->
+    </div>
+    <div class="dropdown-divider"></div>
+    {{#pendingContactRequest}}<button class="dropdown-item delete-contact"><i class="dropdown-marginal icon ion-help"></i>Cancel pending contact request</button>{{/pendingContactRequest}}
+    {{^pendingContactRequest}}<button class="dropdown-item delete-contact"><i class="dropdown-marginal icon ion-trash-b"></i>Delete contact</button>{{/pendingContactRequest}}
+  </div>
+</div>

examples/webchat/htdocs/templates/conversation-index-entry.html

@@ -0,0 +1,8 @@
+<div class="card conversation-card">
+  <div class="card-block {{#isSelected}}bg-primary text-white{{/isSelected}}">
+    <div class="card-title">{{title}}{{^title}}<i>Untitled</i>{{/title}}</div>
+    {{#members}}
+    <img src="{{avatar}}">
+    {{/members}}
+  </div>
+</div>

examples/webchat/htdocs/templates/grant-entry.html

@@ -0,0 +1,2 @@
+<li>{{issuer}} {{grantee}} {{permission}} {{isDelegable}}
+  <button class="revoke">Revoke</button></li>

examples/webchat/htdocs/templates/invitee-entry.html

@@ -0,0 +1,7 @@
+<div class="col-xs-12 col-md-6 col-lg-4 p-1">
+  <div class="cursor-interactive contact-list-present-{{isPresent}} toggle-invitee-status p-2 {{#isInvited}}bg-primary text-white{{/isInvited}} rounded">
+    {{#isInvited}}<span class="invited-tick"><i class="icon ion-checkmark"></i></span>{{/isInvited}}
+    {{^isInvited}}<img class="avatar" src="{{avatar}}">{{/isInvited}}
+    <span class="forcewrap">{{email}}</span>
+  </div>
+</div>

examples/webchat/htdocs/templates/nav-account.html

@@ -0,0 +1,24 @@
+<li class="nav-item dropdown">
+  <span class="nav-link dropdown-toggle contact-list-present-{{globallyVisible}} cursor-interactive" data-toggle="dropdown" id="nav-account">
+    <img class="avatar" src="{{avatar}}">
+    <span class="alert-count hide-zero-count count{{questionCount}}">{{questionCount}}</span>
+    <span class="forcewrap">{{email}}</span></span>
+  <div class="dropdown-menu dropdown-menu-right" aria-labelledby="nav-account">
+    <button class="dropdown-item toggleInvisible"><i class="icon ion-checkmark dropdown-marginal" {{#locallyVisible}}hidden{{/locallyVisible}}></i>Be invisible</button>
+    <div class="dropdown-divider"></div>
+    <a class="dropdown-item" href="#/conversations">Conversations</a>
+    <div class="dropdown-divider"></div>
+    <a class="dropdown-item" href="#/permissions">Permissions...</a>
+    <div class="dropdown-divider"></div>
+    <a class="dropdown-item" href="#/questions">
+      <span class="alert-count hide-zero-count count{{questionCount}}">{{questionCount}}</span>
+      Question<span class="plural count{{questionCount}}">s</span> waiting for your answer</a>
+    <a class="dropdown-item" href="#/my-requests">
+      <span class="normal-count hide-zero-count count{{myRequestCount}}">{{myRequestCount}}</span>
+      Request<span class="plural count{{myRequestCount}}">s</span> for others to answer</a>
+    <div class="dropdown-divider"></div>
+    <a class="dropdown-item" href="#/contacts">Manage contacts</a>
+    <div class="dropdown-divider"></div>
+    <a class="dropdown-item" href="/logout">Log out</a>
+  </div>
+</li>

examples/webchat/htdocs/templates/option-question.html

@@ -0,0 +1,11 @@
+<div class="card col-xs-12 col-lg-6 {{questionClass}}">
+  <div class="card-block">
+    <h4 class="card-title">{{title}}</h4>
+    {{&blurb}}
+    <div class="list-group">
+      {{#options}}
+      <button class="list-group-item list-group-item-action response" data-value="{{0}}">{{1}}</button>
+      {{/options}}
+    </div>
+  </div>
+</div>

examples/webchat/htdocs/templates/page-contacts.html

@@ -0,0 +1,11 @@
+<h2>Add a new contact</h2>
+<form class="form-inline">
+  <label for="add-contact-email">New contact email: </label>
+  <input class="form-control" id="add-contact-email" type="email">
+  <button class="btn btn-default" id="add-contact">Add contact</button>
+</form>
+
+<h2>Contact List</h2>
+<div class="container">
+  <div class="contact-list" class="row"></div>
+</div>

examples/webchat/htdocs/templates/page-conversations.html

@@ -0,0 +1,157 @@
+<div class="modal fade" id="invitation-modal" tabindex="-1" role="dialog" aria-hidden="true">
+  <div class="modal-dialog" role="document">
+    <form class="modal-content">
+      <div class="modal-header">
+        <button type="button" class="close" data-dismiss="modal" aria-label="Close">
+          <span aria-hidden="true">&times;</span>
+        </button>
+        <h4 class="modal-title" id="myModalLabel">Invite User</h4>
+      </div>
+      <div class="modal-body">
+        <label for="invited-username">User to invite:</label>
+        <input type="email" class="form-control" id="invited-username" placeholder="username@example.com">
+      </div>
+      <div class="modal-footer">
+        <button type="button" class="btn btn-secondary" data-dismiss="modal">Cancel</button>
+        <button class="btn btn-primary btn-default send-invitation">Invite</button>
+      </div>
+    </form>
+  </div>
+</div>
+
+<div class="container h-100">
+  <div class="row h-100">
+    {{#showConversationList}}
+    <div class="col-md-4 h-100 column-container">
+      <div id="conversation-list" class="column-fill">
+      </div>
+      <div class="align-center">
+        <a class="big-icon text-gray-dark" href="#/new-chat"><i class="cursor-interactive icon ion-plus-circled"></i></a>
+      </div>
+    </div>
+    {{/showConversationList}}
+    {{#showConversationMain}}
+    <div id="conversation-main" class="col-md-8 h-100 column-container">
+      {{#selected}}
+
+      <div class="column-fill post-backdrop {{^miniMode}}not-{{/miniMode}}mini-mode">
+        {{#miniMode}}
+        <div class="conversation-control-panel bg-primary text-white px-1 mb-1">
+          <div class="float-right dropdown">
+            <i class="cursor-interactive icon ion-more" data-toggle="dropdown"></i>
+            <div class="dropdown-menu dropdown-menu-right">
+              {{#overflowMenuItems}}
+              {{#separator}}
+              <div class="dropdown-divider"></div>
+              {{/separator}}
+              {{^separator}}
+              <button class="dropdown-item {{action}}">{{label}}</button>
+              {{/separator}}
+              {{/overflowMenuItems}}
+            </div>
+          </div>
+          <i class="toggle-info-mode float-right icon ion-information-circled pr-1"></i>
+          {{#showConversationInfo}}
+          <i class="end-info-mode icon ion-arrow-left-c" style="padding-right: 0.5rem"></i>
+          {{/showConversationInfo}}
+          {{^showConversationInfo}}
+          <a class="text-white" style="padding-right: 0.5rem" href="#/conversations"><i class="icon ion-arrow-left-c"></i></a>
+          {{/showConversationInfo}}
+          <span>{{title}}{{^title}}<i class="text-muted">Untitled</i>{{/title}}</span>
+        </div>
+        {{/miniMode}}
+
+        {{#showConversationInfo}}
+        <div>
+          <div class="float-right dropdown mr-1">
+            <i class="cursor-interactive big-icon icon ion-more" data-toggle="dropdown"></i>
+            <div class="dropdown-menu dropdown-menu-right">
+              {{#overflowMenuItems}}
+              {{^hidden}}
+              {{#separator}}
+              <div class="dropdown-divider"></div>
+              {{/separator}}
+              {{^separator}}
+              <button class="dropdown-item {{action}}">{{label}}</button>
+              {{/separator}}
+              {{/hidden}}
+              {{/overflowMenuItems}}
+            </div>
+          </div>
+          {{#editingTitle}}
+          <h2 class="mr-1">
+            <form class="form-inline">
+              <input type="text" autocomplete="off" class="form-control" id="conversation-title" value="{{title}}">
+              <button class="form-control btn btn-primary btn-default" id="accept-conversation-title"><i class="icon ion-checkmark"></i></button>
+              <button class="form-control btn btn-secondary" id="cancel-edit-conversation-title"><i class="icon ion-close"></i></button>
+            </form>
+          </h2>
+          {{/editingTitle}}
+          {{^editingTitle}}
+          <form class="form-inline float-right">
+            <button class="form-control btn" id="edit-conversation-title"><i class="icon ion-edit"></i></button>
+          </form>
+          <h2 id="title-heading">{{title}}{{^title}}<i class="text-muted">Untitled</i>{{/title}}</h2>
+          {{/editingTitle}}
+          <hr>
+
+          {{#editingBlurb}}
+          <div class="mr-1">
+            <textarea rows="3" class="form-control" id="conversation-blurb">{{blurb}}</textarea>
+            <form class="form-inline align-right pb-1">
+              <button class="form-control btn btn-primary btn-default" id="accept-conversation-blurb"><i class="icon ion-checkmark"></i></button>
+              <button class="form-control btn btn-secondary" id="cancel-edit-conversation-blurb"><i class="icon ion-close"></i></button>
+            </form>
+          </div>
+          {{/editingBlurb}}
+          {{^editingBlurb}}
+          <div>
+            <form class="form-inline float-right">
+              <button class="form-control btn" id="edit-conversation-blurb"><i class="icon ion-edit"></i></button>
+            </form>
+            <div id="blurb" class="blurb-box">
+              {{#blurb}}
+              <p>{{blurb}}</p>
+              {{/blurb}}
+              {{^blurb}}
+              <p><i class="text-muted">Set a conversation topic here</i></p>
+              {{/blurb}}
+            </div>
+          </div>
+          {{/editingBlurb}}
+        </div>
+        {{/showConversationInfo}}
+
+        {{#showConversationPosts}}
+        <div class="posts"></div>
+        {{/showConversationPosts}}
+      </div>
+      {{#showConversationPosts}}
+      <div id="pending-draft-items">
+      </div>
+      <form id="message-input-form" class="form-inline pt-1" style="display: flex;">
+        <input type="text" autocomplete="off" id="message-input" class="form-control" style="flex: 1">
+        <input type="file" style="display: none;" hidden id="attach-item-file">
+        <button type="button" id="attach-item-button" class="form-control btn btn-secondary" style="max-width: 3em; font-size: 120%;"><i class="icon ion-paperclip"></i></button>
+        <button type="submit"  id="send-message-button" class="form-control btn btn-primary btn-default" style="max-width: 3em"><i class="icon ion-paper-airplane"></i></button>
+      </form>
+      {{/showConversationPosts}}
+
+      {{/selected}}
+
+      {{^selected}}
+      <p class="align-center">
+        Select a conversation from the column to the left,
+        or <a href="#/new-chat">create a new conversation</a>.
+      </p>
+      {{/selected}}
+    </div>
+    {{/showConversationMain}}
+  </div>
+</div>
+{{#miniMode}}
+<style>
+  footer { display: none; }
+  #message-input-form { margin-bottom: 1rem; }
+</style>
+{{/miniMode}}

examples/webchat/htdocs/templates/page-my-requests.html

@@ -0,0 +1,3 @@
+<h2>Requests I have made</h2>
+<p class="show-only-zero-count count{{myRequestCount}}">You have no outstanding requests waiting for responses from others.</p>
+<ul id="my-permission-requests"></ul>

examples/webchat/htdocs/templates/page-new-chat.html

@@ -0,0 +1,35 @@
+<h2>New Conversation</h2>
+<hr>
+
+<h4>Select people to add</h4>
+<div class="input-group">
+  <input class="form-control"
+         type="search"
+         id="search-contacts"
+         placeholder="Search contacts"
+         value="{{searchString}}">
+  <div class="input-group-addon"><i class="icon ion-search"></i></div>
+</div>
+<div class="container">
+  <div class="contact-list" class="row"></div>
+</div>
+
+<hr>
+<h4>Configure the conversation</h4>
+<form>
+  <div class="form-group">
+    <label for="conversation-title">Conversation Title</label>
+    <input type="text" autocomplete="off" class="form-control" id="conversation-title">
+  </div>
+  <div class="form-group">
+    <label for="conversation-blurb">Conversation Description</label>
+    <textarea class="form-control" id="conversation-blurb" rows="3"></textarea>
+  </div>
+
+  <button type="submit" class="btn btn-success create-conversation {{#noInvitees}}disabled{{/noInvitees}}">Create conversation</button>
+  {{#noInvitees}}
+  <div class="alert alert-danger">
+    You must invite at least one person to the conversation.
+  </div>
+  {{/noInvitees}}
+</form>

examples/webchat/htdocs/templates/page-permissions.html

@@ -0,0 +1,5 @@
+<h2>Permissions I enjoy</h2>
+<ul id="permissions"></ul>
+
+<h2>Permissions I have granted to others</h2>
+<ul id="grants"></ul>

examples/webchat/htdocs/templates/page-questions.html

@@ -0,0 +1,23 @@
+<h2>Questions</h2>
+<div class="show-only-zero-count count{{questionCount}}">
+  <p>There are no questions waiting for you to answer.</p>
+  <ul>
+    <li><a href="#/conversations">Go to conversation list.</a></li>
+    <li><a href="#/contacts">Go to contacts list.</a></li>
+  </ul>
+</div>
+<div class="container">
+  <div id="question-container" class="row"></div>
+</div>
+<div class="hide-zero-count count{{otherRequestCount}}">
+  <p>
+    <label for="show-all-requests-from-others">Show all pending requests from others? </label>
+    <input type="checkbox" id="show-all-requests-from-others" {{#showRequestsFromOthers}}checked{{/showRequestsFromOthers}}>
+  </p>
+  {{#showRequestsFromOthers}}
+  <div id="all-requests-from-others-div">
+    <h2>All requests from others</h2>
+    <ul id="others-permission-requests"></ul>
+  </div>
+  {{/showRequestsFromOthers}}
+</div>

examples/webchat/htdocs/templates/permission-entry.html

@@ -0,0 +1,2 @@
+<li>{{issuer}} {{permission}} {{isDelegable}}
+  {{#isRelinquishable}}<button class="relinquish">Relinquish</button>{{/isRelinquishable}}</li>

examples/webchat/htdocs/templates/permission-request-in-GENERIC.html

@@ -0,0 +1,3 @@
+<li>{{issuer}} {{grantee}} {{permissionJSON}}
+  <a href="" class="btn btn-sm btn-primary grant">Grant</a>
+  <a href="" class="btn btn-sm btn-secondary deny">Deny</a></li>

examples/webchat/htdocs/templates/permission-request-in-p:follow.html

@@ -0,0 +1,3 @@
+<li>Request from {{grantee}} to follow {{permission.fields.0}}
+  <a href="" class="btn btn-sm btn-primary grant">Grant</a>
+  <a href="" class="btn btn-sm btn-secondary deny">Deny</a></li>

examples/webchat/htdocs/templates/permission-request-out-GENERIC.html

@@ -0,0 +1 @@
+<li>q {{issuer}} {{permissionJSON}} <a href="" class="btn btn-sm btn-secondary cancel">Cancel</a></li>

examples/webchat/htdocs/templates/permission-request-out-p:follow.html

@@ -0,0 +1 @@
+<li>Request to follow {{issuer}} <a href="" class="btn btn-sm btn-secondary cancel">Cancel</a></li>

examples/webchat/htdocs/templates/post-entry.html

@@ -0,0 +1,7 @@
+<div id="post-{{postId}}" class="post {{#fromMe}}from-me{{/fromMe}}{{^fromMe}}to-me{{/fromMe}}">
+  <div class="post-body {{contentClass}} clearfix">
+    {{^fromMe}}<p class="post-author text-muted">{{author}}</p>{{/fromMe}}
+    <div class="post-item-container"></div>
+    <div class="post-date text-muted">{{time}}</div>
+  </div>
+</div>

examples/webchat/htdocs/templates/post-item-application-octet-stream.html

@@ -0,0 +1,8 @@
+<table class="application-octet-stream">
+  <tr>
+    <td><a href="{{itemURL}}"><img src="/Text-x-generic.svg"></a></td>
+  </tr>
+  <tr>
+    <td>{{item.type}}</td>
+  </tr>
+</table>

examples/webchat/htdocs/templates/post-item-image.html

@@ -0,0 +1 @@
+<img class="post-item-image" src="{{itemURL}}">

examples/webchat/htdocs/templates/post-item-text-plain.html

@@ -0,0 +1 @@
+<p>{{item.data}}</p>

examples/webchat/htdocs/templates/post-item.html

@@ -0,0 +1,4 @@
+<div id="{{itemId}}" class="post-item {{#postInfo.isDraft}}post-item-draft{{/postInfo.isDraft}} {{contentClass}} clearfix">
+  {{#postInfo.isDraft}}<button class="btn close-draft"><i class="icon ion-close"></i></button>{{/postInfo.isDraft}}
+  <div class="post-item-body-container"></div>
+</div>

examples/webchat/htdocs/webchat.syndicate.js

@@ -0,0 +1,959 @@
+(function () {
+  // N.B.: "window.status" is an HTML-defined property, and always a
+  // string, so naming things at "global"-level `status` will not have
+  // the desired effect!
+  assertion type online();
+  assertion type present(email);
+
+  assertion type uiTemplate(name, data) = "ui-template";
+
+  assertion type permitted(issuer, email, permission, isDelegable);
+  assertion type grant(issuer, grantor, grantee, permission, isDelegable);
+  assertion type permissionRequest(issuer, grantee, permission) = "permission-request";
+
+  assertion type conversation(id, title, creator, blurb);
+  assertion type invitation(conversationId, inviter, invitee);
+  assertion type inConversation(conversationId, member) = "in-conversation";
+  assertion type post(id, timestamp, conversationId, author, items);
+
+  message type createResource(description) = "create-resource";
+  message type updateResource(description) = "update-resource";
+  message type deleteResource(description) = "delete-resource";
+
+  assertion type pFollow(email) = "p:follow";
+  // assertion type pInvite(email) = "p:invite";
+  // assertion type pSeePresence(email) = "p:see-presence";
+
+  assertion type contactListEntry(owner, member) = "contact-list-entry";
+
+  assertion type question(id, timestamp, klass, target, title, blurb, type);
+  assertion type answer(id, value);
+  assertion type yesNoQuestion(falseValue, trueValue) = "yes/no-question";
+  assertion type optionQuestion(options) = "option-question";
+  // ^ options = [[Any, Markdown]]
+  assertion type textQuestion(isMultiline) = "text-question";
+  assertion type acknowledgeQuestion() = "acknowledge-question";
+
+  //---------------------------------------------------------------------------
+  // Local assertions and messages
+
+  assertion type selectedCid(cid); // currently-selected conversation ID, or null
+  message type windowWidthChanged(newWidth);
+
+  assertion type draftItem(timestamp, dataURL);
+  message type draftSent();
+
+  //---------------------------------------------------------------------------
+
+  var brokerConnected = Syndicate.Broker.brokerConnected;
+  var brokerConnection = Syndicate.Broker.brokerConnection;
+  var toBroker = Syndicate.Broker.toBroker;
+  var fromBroker = Syndicate.Broker.fromBroker;
+  var forceBrokerDisconnect = Syndicate.Broker.forceBrokerDisconnect;
+
+  ///////////////////////////////////////////////////////////////////////////
+
+  function compute_broker_url() {
+    var u = new URL(document.location);
+    u.protocol = (u.protocol === 'http:') ? 'ws:' : 'wss:';
+    u.pathname = '/broker';
+    u.hash = '';
+    return u.toString();
+  }
+
+  var sessionInfo = {}; // filled in by 'load' event handler
+  var brokerUrl = compute_broker_url();
+
+  function outbound(x) {
+    return toBroker(brokerUrl, x);
+  }
+
+  function inbound(x) {
+    return fromBroker(brokerUrl, x);
+  }
+
+  function avatar(email) {
+    return 'https://www.gravatar.com/avatar/' + md5(email.trim().toLowerCase()) + '?s=48&d=retro';
+  }
+
+  ///////////////////////////////////////////////////////////////////////////
+
+  document.addEventListener('dragover', function (e) {
+    e.preventDefault(); // make it so drag-and-drop doesn't load the dropped object into the browser
+  });
+
+  window.addEventListener('load', function () {
+    if (document.body.id === 'webchat-main') {
+      $('head meta').each(function (_i, tag) {
+        var itemprop = tag.attributes.itemprop;
+        var prefix = 'webchat-session-';
+        if (itemprop && itemprop.value.startsWith(prefix)) {
+          var key = itemprop.value.substring(prefix.length);
+          var value = tag.attributes.content.value;
+          sessionInfo[key] = value;
+        }
+      });
+      webchat_main();
+    }
+  });
+
+  function webchat_main() {
+    ground dataspace G {
+      Syndicate.UI.spawnUIDriver({
+        defaultLocationHash: '/conversations'
+      });
+      Syndicate.WakeDetector.spawnWakeDetector();
+      Syndicate.Broker.spawnBrokerClientDriver();
+      spawnInputChangeMonitor();
+
+      spawn {
+        this.ui = new Syndicate.UI.Anchor();
+        var mainpage_c = this.ui.context('mainpage');
+
+        field this.connectedTo = null;
+        field this.myRequestCount = 0; // requests *I* have made of others
+        field this.otherRequestCount = 0; // requests *others* have made of me
+        field this.questionCount = 0; // questions from the system
+        field this.globallyVisible = false; // mirrors *other people's experience of us*
+        field this.locallyVisible = true;
+        field this.showRequestsFromOthers = false;
+        field this.miniMode = $(window).width() < 768;
+
+        window.addEventListener('resize', Syndicate.Dataspace.wrap(function () {
+          :: windowWidthChanged($(window).width());
+        }));
+
+        on message windowWidthChanged($newWidth) {
+          this.miniMode = newWidth < 768;
+        }
+
+        assert brokerConnection(brokerUrl);
+
+        on asserted brokerConnected($url) { this.connectedTo = url; }
+        on retracted brokerConnected(_) { this.connectedTo = null; }
+
+        during inbound(online()) {
+          on start { this.globallyVisible = true; }
+          on stop { this.globallyVisible = false; }
+        }
+
+        during inbound(question($qid, _, _, sessionInfo.email, _, _, _)) {
+          on start { this.questionCount++; }
+          on stop { this.questionCount--; }
+        }
+
+        during inbound(permissionRequest($issuer, sessionInfo.email, $permission)) {
+          on start { this.myRequestCount++; }
+          on stop { this.myRequestCount--; }
+        }
+
+        during inbound(uiTemplate("nav-account.html", $entry)) {
+          var c = this.ui.context('nav', 0, 'account');
+          assert outbound(online()) when (this.locallyVisible);
+          assert c.html('#nav-ul', Mustache.render(entry, {
+            email: sessionInfo.email,
+            avatar: avatar(sessionInfo.email),
+            questionCount: this.questionCount,
+            myRequestCount: this.myRequestCount,
+            otherRequestCount: this.otherRequestCount,
+            globallyVisible: this.globallyVisible,
+            locallyVisible: this.locallyVisible
+          }));
+          on message c.event('.toggleInvisible', 'click', _) {
+            this.locallyVisible = !this.locallyVisible;
+          }
+        }
+
+        during Syndicate.UI.locationHash('/contacts') {
+          during inbound(uiTemplate("page-contacts.html", $mainEntry)) {
+            assert mainpage_c.html('div#main-div', Mustache.render(mainEntry, {}));
+          }
+
+          during inbound(uiTemplate("contact-entry.html", $entry)) {
+            during mainpage_c.fragmentVersion($mainpageVersion) {
+              during inbound(contactListEntry(sessionInfo.email, $contact)) {
+                field this.pendingContactRequest = false;
+                field this.isPresent = false;
+                during inbound(present(contact)) {
+                  on start { this.isPresent = true; }
+                  on stop { this.isPresent = false; }
+                }
+                during inbound(permissionRequest(contact, sessionInfo.email, pFollow(contact))) {
+                  on start { this.pendingContactRequest = true; }
+                  on stop { this.pendingContactRequest = false; }
+                }
+                var c = this.ui.context(mainpageVersion, 'all-contacts', contact);
+                assert c.html('.contact-list', Mustache.render(entry, {
+                  email: contact,
+                  avatar: avatar(contact),
+                  pendingContactRequest: this.pendingContactRequest,
+                  isPresent: this.isPresent
+                }));
+                on message c.event('.delete-contact', 'click', _) {
+                  if (confirm((this.pendingContactRequest
+                               ? "Cancel contact request to "
+                               : "Delete contact ")
+                              + contact + "?")) {
+                    :: outbound(deleteResource(permitted(sessionInfo.email,
+                                                         contact,
+                                                         pFollow(sessionInfo.email),
+                                                         false))); // TODO: true too?!
+                  }
+                }
+              }
+            }
+          }
+
+          during mainpage_c.fragmentVersion($mainpageVersion) {
+            during inputValue('#add-contact-email', $rawContact) {
+              var contact = rawContact && rawContact.trim();
+              if (contact) {
+                on message mainpage_c.event('#add-contact', 'click', _) {
+                  :: outbound(createResource(grant(sessionInfo.email,
+                                                   sessionInfo.email,
+                                                   contact,
+                                                   pFollow(sessionInfo.email),
+                                                   false)));
+                  $('#add-contact-email').val('');
+                }
+              }
+            }
+          }
+        }
+
+        during Syndicate.UI.locationHash('/permissions') {
+          during inbound(uiTemplate("page-permissions.html", $mainEntry)) {
+            assert mainpage_c.html('div#main-div', Mustache.render(mainEntry, {}));
+          }
+
+          during inbound(uiTemplate("permission-entry.html", $entry)) {
+            during mainpage_c.fragmentVersion($mainpageVersion) {
+              during inbound(permitted($i, $e, $p, $d)) {
+                if (i !== sessionInfo.email) {
+                  var c = this.ui.context(mainpageVersion, 'permitted', i, e, p, d);
+                  assert c.html('#permissions', Mustache.render(entry, {
+                    issuer: i,
+                    email: e,
+                    permission: JSON.stringify(p),
+                    isDelegable: d,
+                    isRelinquishable: i !== e
+                  }));
+                  on message c.event('.relinquish', 'click', _) {
+                    :: outbound(deleteResource(permitted(i, e, p, d)));
+                  }
+                }
+              }
+            }
+          }
+
+          during inbound(uiTemplate("grant-entry.html", $entry)) {
+            during mainpage_c.fragmentVersion($mainpageVersion) {
+              during inbound(grant($i, sessionInfo.email, $ge, $p, $d)) {
+                var c = this.ui.context(mainpageVersion, 'granted', i, ge, p, d);
+                assert c.html('#grants', Mustache.render(entry, {
+                  issuer: i,
+                  grantee: ge,
+                  permission: JSON.stringify(p),
+                  isDelegable: d
+                }));
+                on message c.event('.revoke', 'click', _) {
+                  :: outbound(deleteResource(grant(i, sessionInfo.email, ge, p, d)));
+                }
+              }
+            }
+          }
+        }
+
+        during Syndicate.UI.locationHash('/my-requests') {
+          during inbound(uiTemplate("page-my-requests.html", $mainEntry)) {
+            assert mainpage_c.html('div#main-div', Mustache.render(mainEntry, {
+              myRequestCount: this.myRequestCount
+            }));
+          }
+
+          during inbound(permissionRequest($issuer, sessionInfo.email, $permission)) {
+            during inbound(uiTemplate("permission-request-out-GENERIC.html", $genericEntry)) {
+              during mainpage_c.fragmentVersion($mainpageVersion) {
+                var c = this.ui.context(mainpageVersion, 'my-permission-request', issuer, permission);
+                field this.entry = genericEntry;
+                assert c.html('#my-permission-requests', Mustache.render(this.entry, {
+                  issuer: issuer,
+                  permission: permission,
+                  permissionJSON: JSON.stringify(permission)
+                })) when (this.entry);
+                var specificTemplate = "permission-request-out-" +
+                    encodeURIComponent(permission.meta.label) + ".html";
+                on asserted inbound(uiTemplate(specificTemplate, $specificEntry)) {
+                  this.entry = specificEntry || genericEntry;
+                }
+                on message c.event('.cancel', 'click', _) {
+                  :: outbound(deleteResource(permissionRequest(issuer, sessionInfo.email, permission)));
+                }
+              }
+            }
+          }
+        }
+
+        during Syndicate.UI.locationHash('/questions') {
+          during inbound(uiTemplate("page-questions.html", $mainEntry)) {
+            assert mainpage_c.html('div#main-div', Mustache.render(mainEntry, {
+              questionCount: this.questionCount,
+              otherRequestCount: this.otherRequestCount,
+              showRequestsFromOthers: this.showRequestsFromOthers
+            }));
+          }
+
+          during mainpage_c.fragmentVersion($mainpageVersion) {
+            during inputValue('#show-all-requests-from-others', $showRequestsFromOthers) {
+              on start { this.showRequestsFromOthers = showRequestsFromOthers; }
+            }
+          }
+
+          during inbound(uiTemplate("permission-request-in-GENERIC.html", $genericEntry)) {
+            during mainpage_c.fragmentVersion($mainpageVersion) {
+              during inbound(permissionRequest($issuer, $grantee, $permission)) {
+                if (grantee !== sessionInfo.email) {
+                  on start { this.otherRequestCount++; }
+                  on stop { this.otherRequestCount--; }
+
+                  var c = this.ui.context(mainpageVersion, 'others-permission-request', issuer, grantee, permission);
+                  field this.entry = genericEntry;
+                  assert c.html('#others-permission-requests', Mustache.render(this.entry, {
+                    issuer: issuer,
+                    grantee: grantee,
+                    permission: permission,
+                    permissionJSON: JSON.stringify(permission)
+                  })) when (this.entry);
+                  var specificTemplate = "permission-request-in-" +
+                      encodeURIComponent(permission.meta.label) + ".html";
+                  on asserted inbound(uiTemplate(specificTemplate, $specificEntry)) {
+                    this.entry = specificEntry || genericEntry;
+                  }
+                  on message c.event('.grant', 'click', _) {
+                    :: outbound(createResource(grant(issuer,
+                                                     sessionInfo.email,
+                                                     grantee,
+                                                     permission,
+                                                     false)));
+                  }
+                  on message c.event('.deny', 'click', _) {
+                    :: outbound(deleteResource(permissionRequest(issuer, grantee, permission)));
+                  }
+                }
+              }
+            }
+          }
+
+          during inbound(question($qid, $timestamp, $klass, sessionInfo.email, $title, $blurb, $qt))
+          {
+            during mainpage_c.fragmentVersion($mainpageVersion) {
+              var c = this.ui.context(mainpageVersion, 'question', timestamp, qid);
+
+              switch (qt.meta.label) {
+                case "option-question": {
+                  var options = qt.fields[0];
+                  during inbound(uiTemplate("option-question.html", $entry)) {
+                    assert c.html('#question-container', Mustache.render(entry, {
+                      questionClass: klass,
+                      title: title,
+                      blurb: blurb,
+                      options: options
+                    }));
+                    on message c.event('.response', 'click', $e) {
+                      react { assert outbound(answer(qid, e.target.dataset.value)); }
+                    }
+                  }
+                  break;
+                }
+                default: {
+                  break;
+                }
+              }
+            }
+          }
+        }
+
+        var conversations_re = /^\/conversations(\/(.*))?/;
+        during Syndicate.UI.locationHash($locationHash) {
+          var m = locationHash.match(conversations_re);
+          if (m) {
+            assert selectedCid(m[2] || false);
+          }
+        }
+
+        during inbound(uiTemplate("page-conversations.html", $mainEntry)) {
+          during selectedCid(false) {
+            assert mainpage_c.html('div#main-div', Mustache.render(mainEntry, {
+              miniMode: this.miniMode,
+              showConversationList: true,
+              showConversationMain: !this.miniMode,
+              showConversationInfo: false,
+              showConversationPosts: false,
+              selected: false
+            }));
+          }
+        }
+
+        // Move to the conversation index page when we leave a
+        // conversation (which also happens automatically when it is
+        // deleted)
+        during selectedCid($selected) {
+          on retracted inbound(inConversation(selected, sessionInfo.email)) {
+            :: Syndicate.UI.setLocationHash('/conversations');
+          }
+        }
+
+        during inbound(inConversation($cid, sessionInfo.email)) {
+          field this.members = Immutable.Set();
+          field this.title = '';
+          field this.creator = '';
+          field this.blurb = '';
+          field this.editingTitle = false;
+          field this.editingBlurb = false;
+
+          field this.membersJSON = [];
+          dataflow {
+            this.membersJSON = this.members.map(function (m) { return {
+              email: m,
+              avatar: avatar(m)
+            }; }).toArray();
+          }
+
+          on asserted inbound(inConversation(cid, $who)) {
+            this.members = this.members.add(who);
+          }
+          on retracted inbound(inConversation(cid, $who)) {
+            this.members = this.members.remove(who);
+          }
+
+          on asserted inbound(conversation(cid, $title, $creator, $blurb)) {
+            this.title = title;
+            this.creator = creator;
+            this.blurb = blurb;
+          }
+
+          during inbound(uiTemplate("page-conversations.html", $mainEntry)) {
+            during selectedCid($selected) {
+              if (selected === cid) {
+                field this.showInfoMode = false;
+                field this.latestPostTimestamp = 0;
+                field this.latestPostId = null;
+
+                field this.draftItems = Immutable.Map();
+                on asserted draftItem($ts, $d) { this.draftItems = this.draftItems.set(ts, d); }
+                on retracted draftItem($ts, _) { this.draftItems = this.draftItems.remove(ts); }
+
+                assert mainpage_c.html('div#main-div', Mustache.render(mainEntry, {
+                  miniMode: this.miniMode,
+                  showConversationList: !this.miniMode,
+                  showConversationMain: true,
+                  showConversationInfo: !this.miniMode || this.showInfoMode,
+                  showConversationPosts: !this.miniMode || !this.showInfoMode,
+                  selected: selected,
+                  title: this.title,
+                  blurb: this.blurb,
+                  members: this.membersJSON,
+                  editingTitle: this.editingTitle,
+                  editingBlurb: this.editingBlurb,
+                  overflowMenuItems: [
+                    {label: "Invite user...", action: "invite-to-conversation"},
+                    {label: "Leave conversation", action: "leave-conversation"},
+                    {separator: true,
+                     hidden: sessionInfo.email !== this.creator},
+                    {label: "Delete conversation", action: "delete-conversation",
+                     hidden: sessionInfo.email !== this.creator}
+                  ]
+                }));
+
+                on message mainpage_c.event('#message-input', 'focus', $e) {
+                  setTimeout(function () { e.target.scrollIntoView(false); }, 500);
+                }
+
+                var spawnItemFromDataURL = (function (ui) {
+                  return function (dataURL) {
+                    var timestamp = +(new Date());
+                    spawn {
+                      field this.ui = ui.context('draft-post', timestamp);
+                      assert draftItem(timestamp, dataURL);
+                      manifestPostItem(this.ui,
+                                       '#pending-draft-items',
+                                       {
+                                         isDraft: true,
+                                         postId: 'draft',
+                                         timestamp: timestamp,
+                                         fromMe: true,
+                                         author: sessionInfo.email
+                                       },
+                                       dataURL);
+                      stop on message draftSent();
+                      stop on message this.ui.event('.close-draft', 'click', _);
+                    }
+                  };
+                })(this.ui);
+
+                var handleDataTransfer = function (dataTransfer) {
+                  return dataTransferFiles(dataTransfer, Syndicate.Dataspace.wrap(
+                    function (dataURLs) {
+                      dataURLs.forEach(spawnItemFromDataURL);
+                    }));
+                };
+
+                on message mainpage_c.event('#conversation-main', 'drop', $e) {
+                  handleDataTransfer.call(this, e.dataTransfer);
+                }
+
+                on message mainpage_c.event('#message-input', '+paste', $e) {
+                  if (handleDataTransfer.call(this, e.clipboardData)) {
+                    e.preventDefault();
+                  }
+                }
+
+                on message mainpage_c.event('#attach-item-button', 'click', _) {
+                  console.log('clickenating');
+                  $('#attach-item-file').click();
+                }
+                on message mainpage_c.event('#attach-item-file', 'change', $e) {
+                  if (e.target.files) {
+                    for (var i = 0; i < e.target.files.length; i++) {
+                      var file = e.target.files[i];
+                      var reader = new FileReader();
+                      reader.addEventListener('load', Syndicate.Dataspace.wrap(function (e) {
+                        spawnItemFromDataURL(e.target.result);
+                      }));
+                      reader.readAsDataURL(file);
+                    }
+                  }
+                }
+
+                on message mainpage_c.event('#send-message-button', 'click', _) {
+                  var timestamp = +(new Date());
+                  var items = this.draftItems.entrySeq().toArray();
+                  items.sort(function (a, b) { return a[0] - b[0]; });
+                  var message = ($("#message-input").val() || '').trim();
+                  if (message) {
+                    var b64 = btoa(unescape(encodeURIComponent(message))); // utf-8, then base64
+                    items.push([timestamp,
+                                "data:text/plain;charset=utf-8;base64," + encodeURIComponent(b64)]);
+                  }
+                  if (items.length) {
+                    :: outbound(createResource(post(random_hex_string(16),
+                                                    timestamp,
+                                                    cid,
+                                                    sessionInfo.email,
+                                                    items.map(function (di) { return di[1]; }))));
+                  }
+                  $("#message-input").val('').focus();
+                  :: draftSent();
+                }
+
+                on message mainpage_c.event('.invite-to-conversation', 'click', _) {
+                  $('#invitation-modal').modal({});
+                }
+
+                on message mainpage_c.event('.send-invitation', 'click', _) {
+                  var invitee = $('#invited-username').val().trim();
+                  if (invitee) {
+                    :: outbound(createResource(invitation(cid, sessionInfo.email, invitee)));
+                    $('#invited-username').val('');
+                    $('#invitation-modal').modal('hide');
+                  }
+                }
+
+                on message mainpage_c.event('.leave-conversation', 'click', _) {
+                  :: outbound(deleteResource(inConversation(cid, sessionInfo.email)));
+                }
+
+                on message mainpage_c.event('.delete-conversation', 'click', _) {
+                  if (confirm("Delete this conversation?")) {
+                    :: outbound(deleteResource(conversation(cid,
+                                                            this.title,
+                                                            this.creator,
+                                                            this.blurb)));
+                  }
+                }
+
+                on message mainpage_c.event('.toggle-info-mode', 'click', _) {
+                  this.showInfoMode = !this.showInfoMode;
+                }
+                on message mainpage_c.event('.end-info-mode', 'click', _) {
+                  this.showInfoMode = false;
+                }
+
+                on message mainpage_c.event('#edit-conversation-title', 'click', _) {
+                  this.editingTitle = true;
+                }
+                on message mainpage_c.event('#title-heading', 'dblclick', _) {
+                  this.editingTitle = true;
+                }
+                on message mainpage_c.event('#accept-conversation-title', 'click', _) {
+                  this.title = $('#conversation-title').val();
+                  :: outbound(updateResource(conversation(cid,
+                                                          this.title,
+                                                          this.creator,
+                                                          this.blurb)));
+                  this.editingTitle = false;
+                }
+                on message mainpage_c.event('#cancel-edit-conversation-title', 'click', _) {
+                  this.editingTitle = false;
+                }
+
+                on message mainpage_c.event('#edit-conversation-blurb', 'click', _) {
+                  this.editingBlurb = true;
+                }
+                on message mainpage_c.event('#blurb', 'dblclick', _) {
+                  this.editingBlurb = true;
+                }
+                on message mainpage_c.event('#accept-conversation-blurb', 'click', _) {
+                  this.blurb = $('#conversation-blurb').val();
+                  :: outbound(updateResource(conversation(cid,
+                                                          this.title,
+                                                          this.creator,
+                                                          this.blurb)));
+                  this.editingBlurb = false;
+                }
+                on message mainpage_c.event('#cancel-edit-conversation-blurb', 'click', _) {
+                  this.editingBlurb = false;
+                }
+
+                during mainpage_c.fragmentVersion($mainpageVersion) {
+                  during inbound(post($pid, $timestamp, cid, $author, $items)) {
+                    var fromMe = (author === sessionInfo.email);
+                    var postInfo = {
+                      isDraft: false,
+                      postId: pid,
+                      timestamp: timestamp,
+                      date: new Date(timestamp).toString(),
+                      time: new Date(timestamp).toTimeString().substr(0, 8),
+                      fromMe: fromMe,
+                      author: author
+                    };
+                    if (timestamp > this.latestPostTimestamp) {
+                      this.latestPostTimestamp = timestamp;
+                      this.latestPostId = pid;
+                    }
+                    var c = this.ui.context(mainpageVersion, 'post', timestamp, pid);
+                    during inbound(uiTemplate("post-entry.html", $postEntryTemplate)) {
+                      assert c.html('.posts', Mustache.render(postEntryTemplate, postInfo));
+                      during c.fragmentVersion($postEntryVersion) {
+                        var itemCounter = 0;
+                        items.forEach((function (itemURL) {
+                          manifestPostItem(c.context('item', postEntryVersion, itemCounter++),
+                                           '#post-' + pid + ' .post-item-container',
+                                           postInfo,
+                                           itemURL);
+                        }).bind(this));
+                      }
+                    }
+                  }
+                }
+              }
+
+              during inbound(uiTemplate("conversation-index-entry.html", $indexEntry)) {
+                during mainpage_c.fragmentVersion($mainpageVersion) {
+                  var c = this.ui.context(mainpageVersion, 'conversationIndex', cid);
+                  assert c.html('#conversation-list', Mustache.render(indexEntry, {
+                    isSelected: selected === cid,
+                    selected: selected,
+                    cid: cid,
+                    title: this.title,
+                    creator: this.creator,
+                    members: this.membersJSON
+                  }));
+                  on message c.event('.card-block', 'click', _) {
+                    if (selected === cid) {
+                      :: Syndicate.UI.setLocationHash('/conversations');
+                    } else {
+                      :: Syndicate.UI.setLocationHash('/conversations/' + cid);
+                    }
+                  }
+                }
+              }
+            }
+          }
+        }
+
+        during Syndicate.UI.locationHash('/new-chat') {
+          field this.invitees = Immutable.Set();
+          field this.searchString = '';
+          field this.displayedSearchString = ''; // avoid resetting HTML every keystroke. YUCK
+
+          during inbound(uiTemplate("page-new-chat.html", $mainEntry)) {
+            assert mainpage_c.html('div#main-div', Mustache.render(mainEntry, {
+              noInvitees: this.invitees.isEmpty(),
+              searchString: this.displayedSearchString
+            }));
+          }
+
+          during mainpage_c.fragmentVersion($mainpageVersion) {
+            on message Syndicate.UI.globalEvent('#search-contacts', 'keyup', $e) {
+              this.searchString = e.target.value.trim();
+            }
+
+            on message mainpage_c.event('.create-conversation', 'click', _) {
+              if (!this.invitees.isEmpty()) {
+                var title = $('#conversation-title').val();
+                var blurb = $('#conversation-blurb').val();
+                var cid = random_hex_string(32);
+                :: outbound(createResource(conversation(cid, title, sessionInfo.email, blurb)));
+                :: outbound(createResource(inConversation(cid, sessionInfo.email)));
+                this.invitees.forEach(function (invitee) {
+                  :: outbound(createResource(invitation(cid, sessionInfo.email, invitee)));
+                });
+                :: Syndicate.UI.setLocationHash('/conversations/' + cid);
+              }
+            }
+          }
+
+          during inbound(uiTemplate("invitee-entry.html", $entry)) {
+            during mainpage_c.fragmentVersion($mainpageVersion) {
+              during inbound(contactListEntry(sessionInfo.email, $contact)) {
+                field this.isPresent = false;
+                field this.isInvited = false;
+                dataflow {
+                  this.isInvited = this.invitees.contains(contact);
+                }
+                during inbound(present(contact)) {
+                  on start { this.isPresent = true; }
+                  on stop { this.isPresent = false; }
+                }
+                var c = this.ui.context(mainpageVersion, 'all-contacts', contact);
+                assert c.html('.contact-list', Mustache.render(entry, {
+                  email: contact,
+                  avatar: avatar(contact),
+                  isPresent: this.isPresent,
+                  isInvited: this.isInvited
+                })) when (this.isInvited ||
+                          !this.searchString ||
+                          contact.indexOf(this.searchString) !== -1);
+                on message c.event('.toggle-invitee-status', 'click', _) {
+                  if (this.invitees.contains(contact)) {
+                    this.invitees = this.invitees.remove(contact);
+                  } else {
+                    this.invitees = this.invitees.add(contact);
+                  }
+                  this.displayedSearchString = this.searchString;
+                }
+              }
+            }
+          }
+        }
+      }
+    }
+
+    // G.dataspace.setOnStateChange(function (mux, patch) {
+    //   $("#debug-space").text(Syndicate.prettyTrie(mux.routingTable));
+    // });
+  }
+
+  var nextItemid = 0;
+  function manifestPostItem(uiContext, containerSelector, postInfo, itemURL) {
+    function cleanContentType(t) {
+      t = t.toLowerCase();
+      if (t.startsWith('image/')) {
+        t = 'image';
+      } else {
+        t = t.replace('/', '-');
+      }
+      return t;
+    }
+
+    var item = parseDataURL(itemURL);
+    var itemId = 'post-' + postInfo.postId + '-item-' + nextItemid++;
+    var contentClass = cleanContentType(item.type);
+    var itemInfo = {
+      itemId: itemId,
+      postInfo: postInfo,
+      contentClass: contentClass,
+      item: item,
+      itemURL: itemURL
+    };
+
+    during inbound(uiTemplate("post-item.html", $postItemTemplate)) {
+      field this.entry = false;
+      on asserted inbound(uiTemplate("post-item-" + contentClass + ".html", $entry)) {
+        if (entry) this.entry = entry;
+      }
+      on asserted inbound(uiTemplate("post-item-application-octet-stream.html", $entry)) {
+        if (entry && !this.entry) this.entry = entry;
+      }
+      assert uiContext.html(containerSelector, Mustache.render(postItemTemplate, itemInfo));
+      on asserted uiContext.fragmentVersion($postItemVersion) {
+        var innerContext = uiContext.context('item-body', postItemVersion);
+        assert innerContext.html('#' + itemId + ' .post-item-body-container',
+                                 Mustache.render(this.entry, itemInfo)) when (this.entry);
+        if (!postInfo.isDraft) {
+          on asserted innerContext.fragmentVersion($innerContextVersion) {
+            if ((this.latestPostTimestamp === postInfo.timestamp) &&
+                (this.latestPostId === postInfo.postId)) {
+              setTimeout(function () { $("#post-" + postInfo.postId)[0].scrollIntoView(false); }, 1);
+            }
+          }
+        }
+      }
+    }
+  }
+})();
+
+///////////////////////////////////////////////////////////////////////////
+// Input control value monitoring
+
+assertion type inputValue(selector, value);
+
+function spawnInputChangeMonitor() {
+  function valOf(e) {
+    return e ? (e.type === 'checkbox' ? e.checked : e.value) : null;
+  }
+
+  spawn {
+    during Syndicate.observe(inputValue($selector, _)) spawn {
+      field this.value = valOf($(selector)[0]);
+      assert inputValue(selector, this.value);
+      on message Syndicate.UI.globalEvent(selector, 'change', $e) {
+        this.value = valOf(e.target);
+      }
+    }
+  }
+}
+
+///////////////////////////////////////////////////////////////////////////
+
+function random_hex_string(halfLength) {
+  var bs = new Uint8Array(halfLength);
+  var encoded = [];
+  crypto.getRandomValues(bs);
+  for (var i = 0; i < bs.length; i++) {
+    encoded.push("0123456789abcdef"[(bs[i] >> 4) & 15]);
+    encoded.push("0123456789abcdef"[bs[i] & 15]);
+  }
+  return encoded.join('');
+}
+
+///////////////////////////////////////////////////////////////////////////
+
+function parseDataURL(u) {
+  var pieces;
+
+  if (!u.startsWith('data:')) return null;
+  u = u.substr(5);
+
+  pieces = u.split(',');
+  if (pieces.length !== 2) return null;
+
+  var mimeType = pieces[0];
+  var data = decodeURIComponent(pieces[1]);
+  var isBase64 = false;
+
+  if (mimeType.endsWith(';base64')) {
+    mimeType = mimeType.substr(0, mimeType.length - 7);
+    isBase64 = true;
+  }
+
+  if (isBase64) {
+    data = atob(data);
+  }
+
+  pieces = mimeType.split(';');
+  var type = pieces[0];
+
+  var parameters = {};
+  for (var i = 1; i < pieces.length; i++) {
+    var m = pieces[i].match(/^([^=]+)=(.*)$/);
+    if (m) {
+      parameters[m[1].toLowerCase()] = m[2];
+    }
+  }
+
+  if (type.startsWith('text/')) {
+    var charset = (parameters.charset || 'US-ASCII').toLowerCase();
+    switch (charset) {
+      case 'utf-8':
+        data = decodeURIComponent(escape(data));
+        break;
+      case 'us-ascii':
+      case 'ascii':
+      case 'latin1':
+      case 'iso-8859-1':
+        break;
+      default:
+        console.warn('Unknown charset while decoding data URL:', charset);
+        break;
+    }
+  }
+
+  return {
+    type: type,
+    parameters: parameters,
+    data: data
+  };
+}
+
+///////////////////////////////////////////////////////////////////////////
+
+// Extract file contents from a DataTransfer object
+function dataTransferFiles(d, k) {
+  var items = d.items;
+  var types = d.types;
+  var files = d.files;
+
+  var results = [];
+  var expectedCount = files.length;
+  var completedCount = 0;
+
+  function completeOne() {
+    completedCount++;
+    if (completedCount === expectedCount) {
+      k(results);
+    }
+  }
+
+  for (var i = 0; i < items.length; i++) {
+    (function (i) {
+      var item = items[i];
+      var type = types[i];
+      if (type === 'text/uri-list') {
+        expectedCount++;
+        item.getAsString(function (itemstr) {
+          var firstChunk = itemstr.substr(0, 6).toLowerCase();
+          if (firstChunk.startsWith('http:') || firstChunk.startsWith('https:')) {
+            $.ajax({
+              type: "GET",
+              url: itemstr,
+              beforeSend: function (xhr) {
+                xhr.overrideMimeType('text/plain; charset=x-user-defined');
+              },
+              success: function (_data, _status, xhr) {
+                var contentType = xhr.getResponseHeader('content-type');
+                var rawdata = xhr.responseText;
+                var data = [];
+                for (var j = 0; j < rawdata.length; j++) {
+                  data = data + String.fromCharCode(rawdata.charCodeAt(j) & 0xff);
+                }
+                results.push('data:' + contentType + ';base64,' + encodeURIComponent(btoa(data)));
+                completeOne();
+              },
+              error: function () {
+                completeOne();
+              }
+            });
+          } else {
+            completeOne();
+          }
+        });
+      }
+    })(i);
+  }
+
+  for (var i = 0; i < files.length; i++) {
+    (function (i) {
+      var file = files[i];
+      var reader = new FileReader();
+      reader.addEventListener('load', function (e) {
+        results.push(e.target.result);
+        completeOne();
+      });
+      reader.readAsDataURL(file);
+    })(i);
+  }
+
+  return (expectedCount > 0);
+}

examples/webchat/server/.gitignore

@@ -0,0 +1,2 @@
+testing.rktd
+compiled/main_rkt.*

examples/webchat/server/TODO.md

@@ -0,0 +1,36 @@
+✓ Remove delete-account, use delete-resource of an account instead
+
+✓ Reimplement spawn-session-monitor and end-session to work in terms
+of create-resource and delete-resource, but leave login-link
+idiosyncratic
+
+Factor out resource management into its own module. Introduce a macro
+for describing resources, their cascading deletion conditions, and
+their potential automatic expiries.
+
+Build a persistent resource management module. Adjust
+`immediate-query` to be able to use an alternative `flush!` routine.
+
+  NOTE that automatic expiry in the direct implementation is as simple
+  as `stop-when-timeout`, but cannot be this simple in a persistent
+  implementation: instead, I plan on producing a special "expiries"
+  table, each entry of which specifies a message to send upon expiry.
+
+  NOTE that the trick of producing a base `p:follow` grant record on
+  account creation has to be done differently when there's no
+  always-on account process.
+
+  NOTE that the trick of deleting an `invitation` when a matching
+  `in-conversation` appears also has to be done differently, similarly
+  to the `p:follow` grant mentioned above. However, this might be able
+  to be automated: if there's some kind of `(stop-when E)` where `E`
+  mentions some field or fields of a resource, matching resources can
+  be deleted from the persistent store by an auxiliary process. This
+  would require fairly hairy syntactic analysis though, so it might be
+  better to have some kind of `cascading-delete-when` form to spell
+  out what should be removed on a given event. (Then the `p:follow`
+  case above can be implemented with some kind of
+  `cascading-insert-when`?)
+
+  NOTE that these differences are OK: this is the first time Syndicate
+  has tackled persistence at all in any interesting way.

examples/webchat/server/account.rkt

@@ -0,0 +1,27 @@
+#lang syndicate
+
+(require racket/set)
+
+(require/activate syndicate/reload)
+(require/activate syndicate/supervise)
+
+(require "protocol.rkt")
+(require "duplicate.rkt")
+
+(spawn #:name 'account-manager
+       (stop-when-reloaded)
+       (define/query-set accounts (account $e) e)
+       (on (asserted (session $email _))
+           (when (not (set-member? (accounts) email))
+             (send! (create-resource (account email))))))
+
+(spawn #:name 'account-factory
+       (stop-when-reloaded)
+       (on (message (create-resource ($ a (account $email))))
+           (spawn #:name (list 'account email)
+                  (on-start (log-info "Account ~s created." email))
+                  (on-stop (log-info "Account ~s deleted." email))
+                  (assert a)
+                  (assert (grant email email email (p:follow email) #t))
+                  (stop-when-duplicate a)
+                  (stop-when (message (delete-resource a))))))

examples/webchat/server/api.rkt

@@ -0,0 +1,78 @@
+#lang syndicate
+
+(require/activate syndicate/reload)
+(require/activate syndicate/supervise)
+(require/activate syndicate/broker/server)
+(require/activate syndicate/drivers/web)
+(require/activate "trust.rkt")
+
+(require "protocol.rkt")
+(require "session-cookie.rkt")
+
+(spawn #:name 'broker-listener
+       (stop-when-reloaded)
+       (on (web-request-get (id req) _ ("broker" ()))
+           (when (web-request-header-websocket-upgrade? req)
+             (with-session id
+               [(email sid)
+                (define (scope v) (api (session email sid) v))
+                (spawn-broker-server-connection
+                 id
+                 req
+                 #:scope scope
+                 #:hook (lambda ()
+                          (stop-when (message (end-session sid)))
+                          (stop-when (message (delete-resource (account email))))))]
+               [else
+                (web-respond/xexpr! id
+                                    #:header (web-response-header #:code 401
+                                                                  #:message #"Unauthorized")
+                                    `(html (body (h1 "Unauthorized")
+                                                 (a ((href "/")) "Login"))))]))))
+
+(supervise
+ (spawn #:name 'reflect-trust
+        (stop-when-reloaded)
+        (during (session $who _)
+          (during ($ p (permitted _ who _ _))
+            (assert (api (session who _) p)))
+          (during ($ r (permission-request _ who _))
+            (assert (api (session who _) r)))
+          (during ($ g (grant _ who _ _ _))
+            (assert (api (session who _) g)))
+          (during ($ c (contact-list-entry who _))
+            (assert (api (session who _) c))))))
+
+(supervise
+ (spawn #:name 'reflect-grant-requests
+        (stop-when-reloaded)
+        (during (permission-request $issuer $grantee $permission)
+          (define r (permission-request issuer grantee permission))
+          (during (permitted issuer $grantor permission #t)
+            (assert (api (session grantor _) r))
+            (on (message (api (session grantor _) (delete-resource r)))
+                (send! (delete-resource r)))))))
+
+(supervise
+ (spawn #:name 'take-trust-instructions
+        (stop-when-reloaded)
+
+        (on (message (api (session $grantor _) (create-resource (? grant? $g))))
+            (when (equal? grantor (grant-grantor g))
+              (send! (create-resource g))))
+        (on (message (api (session $grantor _) (delete-resource (? grant? $g))))
+            (when (or (equal? grantor (grant-grantor g))
+                      (equal? grantor (grant-issuer g)))
+              (send! (delete-resource g))))
+
+        (on (message (api (session $principal _) (delete-resource (? permitted? $p))))
+            (when (or (equal? principal (permitted-email p)) ;; relinquish
+                      (equal? principal (permitted-issuer p))) ;; revoke; TODO: deal with delegation
+              (send! (delete-resource p))))
+
+        (on (message (api (session $grantee _) (create-resource (? permission-request? $r))))
+            (when (equal? grantee (permission-request-grantee r))
+              (send! (create-resource r))))
+        (on (message (api (session $grantee _) (delete-resource (? permission-request? $r))))
+            (when (equal? grantee (permission-request-grantee r))
+              (send! (delete-resource r))))))

examples/webchat/server/config.rkt

@@ -0,0 +1,54 @@
+#lang syndicate
+
+(require racket/cmdline)
+(require racket/port)
+
+(require/activate syndicate/reload)
+(require/activate syndicate/supervise)
+(require/activate syndicate/drivers/config)
+(require/activate syndicate/drivers/web)
+(require/activate syndicate/drivers/smtp)
+
+(require "protocol.rkt")
+
+(command-line #:program "webchat"
+
+              #:once-each
+              ["--baseurl" baseurl "Specify the base URL for the server"
+               (spawn #:name (list 'command-line-baseurl baseurl)
+                      (stop-when-reloaded)
+                      (assert (config 'command-line (list 'baseurl baseurl))))]
+              ["--listen" port "Specify HTTP listener port"
+               (spawn #:name (list 'command-line-listen port)
+                      (stop-when-reloaded)
+                      (assert (config 'command-line (list 'listen (string->number port)))))]
+
+              #:multi
+              [("-o" "--option") key vals "Specify a single configuration option"
+               (spawn #:name (list 'config-option key vals)
+                      (stop-when-reloaded)
+                      (assert (config 'command-line
+                                      (cons (string->symbol key)
+                                            (port->list read (open-input-string vals))))))]
+              [("-f" "--config-file") filename "Specify a configuration file to load"
+               (spawn-configuration filename filename
+                                    #:hook (lambda () (stop-when-reloaded)))])
+
+(spawn #:name 'main
+       (stop-when-reloaded)
+
+       (during (config _ (list 'baseurl $u)) (assert (server-baseurl u)))
+       (during (config _ (list 'listen $p))  (assert (web-virtual-host "http" _ p)))
+
+       (during/spawn (config _ (list 'load $module-path))
+         #:spawn supervise/spawn
+         #:name (list 'load module-path)
+         (reloader-mixin* module-path))
+
+       (during (config _ (list 'smtp $h $u $p $m))
+         (match h
+           [(regexp #px"(.*):(.*)" (list _ host port))
+            (assert (smtp-account-config 'smtp-service host #:port (string->number port)
+                                         #:user u #:password p #:ssl-mode m))]
+           [_
+            (assert (smtp-account-config 'smtp-service h #:user u #:password p #:ssl-mode m))])))

examples/webchat/server/contacts.rkt

@@ -0,0 +1,87 @@
+#lang syndicate
+
+(require/activate syndicate/reload)
+(require/activate syndicate/supervise)
+(require/activate "trust.rkt")
+(require/activate "qa.rkt")
+
+(require "protocol.rkt")
+(require "duplicate.rkt")
+
+;; TODO: Move to protocol.rkt
+(struct online () #:prefab)
+(struct present (email) #:prefab)
+
+(supervise
+ (spawn #:name 'reflect-presence
+        (stop-when-reloaded)
+        (during (api (session $who _) (online))
+          (during (permitted who $grantee (p:follow who) _)
+            ;; `who` allows `grantee` to follow them
+            (assert (api (session grantee _) (present who)))))))
+
+(supervise
+ (spawn #:name 'ensure-p:follow-symmetric
+        (stop-when-reloaded)
+        (on (asserted (permitted $A $B (p:follow $maybe-A) _))
+            (when (equal? A maybe-A)
+              (send! (create-resource (permission-request B A (p:follow B))))))
+        (on (retracted (permitted $A $B (p:follow $maybe-A) _))
+            (when (equal? A maybe-A)
+              (send! (delete-resource (permission-request B A (p:follow B))))
+              (send! (delete-resource (permitted B A (p:follow B) ?)))))
+        (on (retracted (permission-request $A $B (p:follow $maybe-A)))
+            (when (equal? A maybe-A)
+              (when (not (immediate-query [query-value #f (permitted A B (p:follow A) _) #t]))
+                (send! (delete-resource (permitted B A (p:follow B) ?))))))))
+
+(supervise
+ (spawn #:name 'contact-list-factory
+        (stop-when-reloaded)
+        (during (permission-request $A $B (p:follow $maybe-A))
+          (when (equal? A maybe-A)
+            (assert (contact-list-entry B A))))
+        (during (permitted $A $B (p:follow $maybe-A) _)
+          (when (equal? A maybe-A)
+            (when (string<? A B)
+              (during (permitted B A (p:follow B) _)
+                (assert (contact-list-entry A B))
+                (assert (contact-list-entry B A))))))))
+
+(supervise
+ (spawn #:name 'contact-list-change-log
+        (stop-when-reloaded)
+        (on (asserted (contact-list-entry $owner $member))
+            (log-info "~s adds ~s to their contact list" owner member))
+        (on (retracted (contact-list-entry $owner $member))
+            (log-info "~s removes ~s from their contact list" owner member))))
+
+(supervise
+ (spawn #:name 'contacts:questions
+        (stop-when-reloaded)
+        ;; TODO: CHECK THE FOLLOWING: When the `permission-request` vanishes (due to
+        ;; satisfaction or rejection), this should remove the question from all eligible
+        ;; answerers at once
+        (during (permission-request $who $grantee ($ p (p:follow _)))
+          (when (equal? who (p:follow-email p))
+            ;; `grantee` wants to follow `who`
+            (during (permitted who $grantor p #t)
+              ;; `grantor` can make that decision
+              (define-values (title blurb)
+                (if (equal? who grantor)
+                    (values (format "Contact request from ~a" grantee)
+                            `(p "User " (b ,grantee) " wants to be able to invite you "
+                                "to conversations and see when you are online."))
+                    (values (format "Contact request from ~a to ~a" grantee who)
+                            `(p "User " (b ,grantee) " wants to be able to invite "
+                                (b ,who) " to conversations and see when they are online."))))
+              (define qid
+                (ask-question! #:title title #:blurb blurb #:target grantor #:class "q-follow"
+                               (option-question (list (list "allow" "Accept")
+                                                      (list "deny" "Reject")
+                                                      (list "ignore" "Ignore")))))
+              (stop-when (asserted (answer qid $v))
+                         (match v
+                           ["allow" (send! (create-resource (grant who grantor grantee p #f)))]
+                           ["deny" (send! (delete-resource (permission-request who grantee p)))]
+                           ["ignore" (void)])))))))

examples/webchat/server/conversation.rkt

@@ -0,0 +1,164 @@
+#lang syndicate
+
+(require racket/port)
+(require markdown)
+
+(require/activate syndicate/reload)
+(require/activate syndicate/supervise)
+(require/activate "trust.rkt")
+
+(require "protocol.rkt")
+(require "duplicate.rkt")
+(require "util.rkt")
+
+(define (user-in-conversation? who cid)
+  (immediate-query [query-value #f (in-conversation cid who) #t]))
+
+(supervise
+ (spawn #:name 'take-conversation-instructions
+        (stop-when-reloaded)
+
+        (on (message (api (session $creator _) (create-resource (? conversation? $c))))
+            (when (equal? creator (conversation-creator c))
+              (send! (create-resource c))))
+        (on (message (api (session $updater _) (update-resource (? conversation? $c))))
+            (when (user-in-conversation? updater (conversation-id c))
+              (send! (update-resource c))))
+        (on (message (api (session $creator _) (delete-resource (? conversation? $c))))
+            (when (equal? creator (conversation-creator c))
+              (send! (delete-resource c))))
+
+        (on (message (api (session $joiner _) (create-resource (? in-conversation? $i))))
+            (when (equal? joiner (in-conversation-member i))
+              (send! (create-resource i))))
+        (on (message (api (session $leaver _) (delete-resource (? in-conversation? $i))))
+            (when (equal? leaver (in-conversation-member i))
+              (send! (delete-resource i))))
+
+        (on (message (api (session $inviter _) (create-resource (? invitation? $i))))
+            (when (equal? inviter (invitation-inviter i))
+              (send! (create-resource i))))
+        (on (message (api (session $who _) (delete-resource (? invitation? $i))))
+            (when (or (equal? who (invitation-inviter i))
+                      (equal? who (invitation-invitee i)))
+              (send! (delete-resource i))))
+
+        (on (message (api (session $who _) (create-resource (? post? $p))))
+            (when (and (user-in-conversation? who (post-conversation-id p))
+                       (equal? who (post-author p)))
+              (send! (create-resource p))))
+        (on (message (api (session $who _) (update-resource (? post? $p))))
+            (when (equal? who (post-author p))
+              (send! (update-resource p))))
+        (on (message (api (session $who _) (delete-resource (? post? $p))))
+            (when (equal? who (post-author p))
+              (send! (delete-resource p))))))
+
+(supervise
+ (spawn #:name 'relay-conversation-state
+        (stop-when-reloaded)
+
+        (during (invitation $cid $inviter $invitee)
+          (assert (api (session invitee _) (invitation cid inviter invitee)))
+          (during ($ c (conversation cid _ _ _))
+            (assert (api (session invitee _) c))))
+
+        (during (in-conversation $cid $who)
+          (during ($ i (invitation cid _ _))
+            (assert (api (session who _) i)))
+          (during ($ i (in-conversation cid _))
+            (assert (api (session who _) i)))
+          (during ($ c (conversation cid _ _ _))
+            (assert (api (session who _) c)))
+          (during ($ p (post _ _ cid _ _))
+            (assert (api (session who _) p))))))
+
+(supervise
+ (spawn #:name 'conversation-factory
+        (stop-when-reloaded)
+        (on (message (create-resource ($ c0 (conversation $cid $title0 $creator $blurb0))))
+            (spawn #:name c0
+                   (field [title title0]
+                          [blurb blurb0])
+                   (define/dataflow c (conversation cid (title) creator (blurb)))
+                   (on-start (log-info "~v created" (c)))
+                   (on-stop (log-info "~v deleted" (c)))
+                   (assert (c))
+                   (stop-when-duplicate (list 'conversation cid))
+                   (stop-when (message (delete-resource (conversation cid _ _ _))))
+                   (on (message (update-resource (conversation cid $newtitle _ $newblurb)))
+                       (title newtitle)
+                       (blurb newblurb))))))
+
+(supervise
+ (spawn #:name 'in-conversation-factory
+        (stop-when-reloaded)
+        (on (message (create-resource ($ i (in-conversation $cid $who))))
+            (spawn #:name i
+                   (on-start (log-info "~s joins conversation ~a" who cid))
+                   (on-stop (log-info "~s leaves conversation ~a" who cid))
+                   (assert i)
+                   (stop-when-duplicate i)
+                   (stop-when (message (delete-resource i)))
+                   (stop-when (message (delete-resource (conversation cid _ _ _))))))))
+
+(supervise
+ (spawn #:name 'invitation-factory
+        (stop-when-reloaded)
+        (on (message (create-resource ($ i (invitation $cid $inviter $invitee))))
+            (spawn #:name i
+                   (on-start (log-info "~s invited to conversation ~a by ~s" invitee cid inviter))
+                   (on-stop (log-info "invitation of ~s to conversation ~a by ~s retracted"
+                                      invitee cid inviter))
+                   (assert i)
+                   (stop-when-duplicate i)
+                   (stop-when (message (delete-resource i)))
+                   (stop-when (message (delete-resource (conversation cid _ _ _))))
+                   (stop-when (asserted (in-conversation cid invitee)))))))
+
+(supervise
+ (spawn #:name 'post-factory
+        (stop-when-reloaded)
+        (on (message (create-resource
+                      ($ p0 (post $pid $timestamp $cid $author $items0))))
+            (spawn #:name p0
+                   (field [items items0])
+                   (define/dataflow p (post pid timestamp cid author (items)))
+                   (assert (p))
+                   (stop-when-duplicate (list 'post cid pid))
+                   (stop-when (message (delete-resource (post pid _ cid _ _))))
+                   (stop-when (message (delete-resource (conversation cid _ _ _))))
+                   (on (message (update-resource (post pid _ cid _ $newitems)))
+                       (items newitems))))))
+
+(supervise
+ (spawn #:name 'conversation:questions
+        (stop-when-reloaded)
+        ;; TODO: CHECK THE FOLLOWING: When the `invitation` vanishes (due to satisfaction
+        ;; or rejection), this should remove the question from all eligible answerers at once
+        (during (invitation $cid $inviter $invitee)
+          ;; `inviter` has invited `invitee` to conversation `cid`...
+          (define qid (random-hex-string 32)) ;; Fix qid and timestamp even as title/creator vary
+          (define timestamp (current-seconds))
+          (during (conversation cid $title $creator _)
+            ;; ...and it exists...
+            (during (permitted invitee inviter (p:follow invitee) _)
+              ;; ...and they are permitted to do so
+              (assert (question qid timestamp "q-invitation" invitee
+                                (format "Invitation from ~a" inviter)
+                                (with-output-to-string
+                                  (lambda ()
+                                    (display-xexpr
+                                     `(div
+                                       (p "You have been invited by " (b ,inviter)
+                                          " to join a conversation started by " (b ,creator) ".")
+                                       (p "The conversation is titled "
+                                          (i "\"" ,title "\"") ".")))))
+                                (option-question (list (list "join" "Join conversation")
+                                                       (list "decline" "Decline invitation")))))
+              (stop-when (asserted (answer qid $v))
+                         (match v
+                           ["join"
+                            (send! (create-resource (in-conversation cid invitee)))]
+                           ["decline"
+                            (send! (delete-resource (invitation cid inviter invitee)))])))))))

examples/webchat/server/duplicate.rkt

@@ -0,0 +1,15 @@
+#lang syndicate
+
+(provide stop-when-duplicate)
+
+(require syndicate/protocol/instance)
+(require "util.rkt")
+
+(define (stop-when-duplicate spec)
+  (define id (random-hex-string 16))
+  (assert (instance id spec))
+  (on (asserted (instance $id2 spec))
+      (when (string<? id id2)
+        (log-info "Duplicate instance of ~v detected; terminating" spec)
+        (stop-current-facet)))
+  id)

examples/webchat/server/main.rkt

@@ -0,0 +1,14 @@
+#lang syndicate
+
+(require/activate syndicate/reload)
+
+(spawn-reloader "config.rkt")
+(spawn-reloader "trust.rkt")
+(spawn-reloader "api.rkt")
+(spawn-reloader "script-compiler.rkt")
+(spawn-reloader "static-content.rkt")
+(spawn-reloader "account.rkt")
+(spawn-reloader "pages.rkt")
+(spawn-reloader "qa.rkt")
+(spawn-reloader "contacts.rkt")
+(spawn-reloader "conversation.rkt")

examples/webchat/server/pages.rkt

@@ -0,0 +1,277 @@
+#lang syndicate
+
+(require racket/dict)
+(require racket/port)
+(require racket/set)
+(require racket/string)
+(require markdown)
+(require net/url)
+(require net/uri-codec)
+
+(require/activate syndicate/reload)
+(require/activate syndicate/supervise)
+(require/activate syndicate/drivers/config)
+(require/activate syndicate/drivers/smtp)
+(require/activate syndicate/drivers/timestate)
+(require/activate syndicate/drivers/web)
+
+(require "protocol.rkt")
+(require "duplicate.rkt")
+(require "session-cookie.rkt")
+
+(define (page #:head [extra-head '()]
+              #:body-id [body-id #f]
+              ;; #:nav-heading [nav-heading `(a ((href "/#/conversations")) "Syndicate Webchat")]
+              title . body-elements)
+  `(html ((lang "en"))
+         (head (meta ((charset "utf-8")))
+               (meta ((http-equiv "X-UA-Compatible") (content "IE=edge")))
+               (meta ((name "viewport") (content "width=device-width, initial-scale=1.0, shrink-to-fit=no")))
+               (meta ((name "format-detection") (content "email=no"))) ;; TODO: Mobile chrome seems to autolink email addresses ?!?!
+               (title ,title)
+               (link ((rel "stylesheet")
+                      (href "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0-alpha.5/css/bootstrap.min.css")
+                      (integrity "sha384-AysaV+vQoT3kOAXZkl02PThvDr8HYKPZhNT5h/CXfBThSRXQ6jW5DO2ekP5ViFdi")
+                      (crossorigin "anonymous")))
+               (script ((src "https://code.jquery.com/jquery-3.1.1.min.js")
+                        (integrity "sha256-hVVnYaiADRTO2PzUGmuLJr8BLUSjGIZsDYGmIJLv2b8=")
+                        (crossorigin "anonymous")))
+               (script ((src "https://cdnjs.cloudflare.com/ajax/libs/tether/1.3.8/js/tether.min.js")
+                        (integrity "sha256-/5pHDZh2fv1eZImyfiThtB5Ag4LqDjyittT7fLjdT/8=")
+                        (crossorigin "anonymous")))
+               (script ((src "https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0-alpha.5/js/bootstrap.min.js")
+                        (integrity "sha384-BLiI7JTZm+JWlgKa0M0kGRpJbF2J8q+qreVrKBC47e3K6BW78kGLrCkeRX6I9RoK")
+                        (crossorigin "anonymous")))
+               (script ((src "https://cdnjs.cloudflare.com/ajax/libs/mustache.js/2.3.0/mustache.min.js")
+                        (integrity "sha256-iaqfO5ue0VbSGcEiQn+OeXxnxAMK2+QgHXIDA5bWtGI=")
+                        (crossorigin "anonymous")))
+               (script ((src "https://cdnjs.cloudflare.com/ajax/libs/blueimp-md5/2.6.0/js/md5.min.js")
+                        (integrity "sha256-I0CACboBQ1ky299/4LVi2tzEhCOfx1e7LbCcFhn7M8Y=")
+                        (crossorigin "anonymous")))
+               (script ((src "https://cdnjs.cloudflare.com/ajax/libs/immutable/3.8.1/immutable.min.js")
+                        (integrity "sha256-13JFytp+tj8jsxr6GQOVLCgcYfMUo2Paw4jVrnXLUPE=")
+                        (crossorigin "anonymous")))
+               (script ((src "/linkify.min.js")))
+               (script ((src "/linkify-string.min.js")))
+               ;; (script ((src "/syndicatecompiler.min.js")))
+               (script ((src "/syndicate.min.js")))
+               (script ((src "/webchat.js")))
+               (link ((rel "stylesheet") (href "http://code.ionicframework.com/ionicons/2.0.1/css/ionicons.min.css")))
+               (link ((rel "stylesheet") (href "/style.css")))
+               ,@extra-head)
+         (body (,@(if body-id
+                      `((id ,body-id))
+                      `()))
+               (div ((class "container main-container"))
+                    (div ((class "header clearfix"))
+                         (nav ((class "navbar"))
+                              ;; (span ((id "nav-heading") (class "navbar-brand text-muted")) ,nav-heading)
+                              (ul ((id "nav-ul") (class "nav navbar-nav nav-pills float-xs-right"))
+                                  ;; (li ((class "nav-item")) (a ((class "nav-link active") (href "#")) "Home " (span ((class "sr-only")) "(current)")))
+                                  ;; (li ((class "nav-item")) (a ((class "nav-link") (href "#")) "About"))
+                                  ;; (li ((class "nav-item")) (a ((class "nav-link") (href "#")) "Contact"))
+                                  )))
+
+                    (div ((id "main-div")))
+                    ;; (div ((class "row marketing"))
+                    ;;      (div ((class "col-lg-6"))
+                    ;;           (h4 "Subheading")
+                    ;;           (p "Donec id elit non mi porta gravida at eget metus. Maecenas faucibus mollis interdum.")
+                    ;;           (h4 "Subheading")
+                    ;;           (p "Morbi leo risus, porta ac consectetur ac, vestibulum at eros. Cras mattis consectetur purus sit amet fermentum.")
+                    ;;           (h4 "Subheading")
+                    ;;           (p "Maecenas sed diam eget risus varius blandit sit amet non magna."))
+                    ;;      (div ((class "col-lg-6"))
+                    ;;           (h4 "Subheading")
+                    ;;           (p "Morbi leo risus, porta ac consectetur ac, vestibulum at eros. Cras mattis consectetur purus sit amet fermentum.")
+                    ;;           (h4 "Subheading")
+                    ;;           (p "Maecenas sed diam eget risus varius blandit sit amet non magna.")
+                    ;;           (h4 "Subheading")
+                    ;;           (p "Donec id elit non mi porta gravida at eget metus. Maecenas faucibus mollis interdum.")))
+
+                    ,@body-elements
+
+                    (footer ((class "footer"))
+                            (p copy " 2010" ndash "2016 Tony Garnock-Jones"))))))
+
+(define (jumbotron heading . contents)
+  `(div ((class "jumbotron"))
+        (h1 ((class "display-3")) ,heading)
+        ,@contents))
+
+(define (logout-this-session! id)
+  (web-redirect! id "/" #:headers (list (format-cookie clear-session-cookie))))
+
+(define (web-respond/pretty-xexpr! id
+                                   #:header [header (web-response-header)]
+                                   body-xexpr)
+  (web-respond/bytes! id
+                      #:header header
+                      (bytes-append #"<!DOCTYPE html>"
+                                    (with-output-to-bytes
+                                      (lambda ()
+                                        ;; This is a very nice compromise pretty-printer
+                                        ;; for xexprs from Greg's Markdown package.
+                                        (display-xexpr body-xexpr))))))
+
+(spawn #:name 'index-page
+       (stop-when-reloaded)
+       (on (web-request-get (id req) _ ("" ()))
+           (index-page id)))
+
+(define (index-page id)
+  (with-session id
+    [(email sid)
+     (serve-single-page-app id sid email)]
+    [else
+     (web-respond/pretty-xexpr!
+      id
+      #:header (web-response-header #:headers (list (format-cookie clear-session-cookie)))
+      (page "Syndicate Webchat"
+            (jumbotron "Log In"
+                       `(p ((class "lead"))
+                           "Enter your email address. You will be emailed a login token.")
+
+                       `(form ((action "/login") (method "post") (class "form-inline"))
+                              (div ((class "form-group"))
+                                   (label ((for "email")) "Email:")
+                                   " "
+                                   (input ((type "email")
+                                           (name "email")
+                                           (id "email")
+                                           (placeholder "your-email@example.com"))))
+                              " "
+                              (button ((type "submit")
+                                       (class "btn btn-success")
+                                       (role "button"))
+                                      "Log In")))))]))
+
+(define (serve-single-page-app id sid email)
+  (web-respond/pretty-xexpr!
+   id
+   (page (format "Webchat: ~a" email)
+         #:body-id "webchat-main"
+         #:head (list `(meta ((itemprop "webchat-session-email") (content ,email)))
+                      `(meta ((itemprop "webchat-session-id") (content ,sid)))))))
+
+;; (define (sessions-page id)
+;;   (with-session id
+;;     [(email sid)
+;;      (define sids (sort (set->list (immediate-query (query-set (session email $s) s))) string<?))
+;;      (web-respond/pretty-xexpr!
+;;       id
+;;       (page "Session Management"
+;;             `(div (h1 "Session Management")
+;;                   (ol ,@(for/list [(s sids)]
+;;                           `(li (a ((href ,(format "/logout/~a" s)))
+;;                                   ,s))))
+;;                   (p (a ((href "/logout-all"))
+;;                         "Logout all sessions"))
+;;                   (p (a ((href "/delete-account"))
+;;                         "Delete account")))))]))
+
+;; (define (logout-all-page id)
+;;   (with-session id
+;;     [(email _sid)
+;;      (for [(sid (immediate-query (query-set (session email $s) s)))]
+;;        (send! (end-session sid)))
+;;      (logout-this-session! id)]
+;;     [else (logout-this-session! id)]))
+
+(spawn #:name 'logout-page
+       (stop-when-reloaded)
+       (on (web-request-get (id req) _ ("logout" ()))
+           (logout-page id)))
+
+(define (logout-page id)
+  (with-session id
+    [(email sid)
+     (send! (end-session sid))
+     (logout-this-session! id)]
+    [else (logout-this-session! id)]))
+
+(spawn #:name 'login-page
+       (stop-when-reloaded)
+       (define/query-value insecure #f (config _ (list 'insecure)) #t)
+       (define/query-value baseurl #f (server-baseurl $b) b)
+
+       (on (web-request-incoming (id req) _ 'post ("login" ()) $body)
+           (define params (make-immutable-hash (form-urlencoded->alist (bytes->string/utf-8 body))))
+           (define email (string-trim (dict-ref params 'email "")))
+           (if (string=? email "")
+               (web-redirect! id "/")
+               (let* ((sid (fresh-session-id))
+                      (validation-url (url->string
+                                       (combine-url/relative (string->url (baseurl))
+                                                             (format "/login/~a" sid)))))
+                 (spawn-login-link email sid)
+                 (login-link-emailed-page id (and (insecure) validation-url))
+                 (when (not (insecure))
+                   (smtp-deliver! 'smtp-service "webchat@syndicate-lang.org" (list email)
+                                  (list (cons 'subject "Login link for Syndicate WebChat")
+                                        (cons 'to email)
+                                        (cons 'from "webchat@syndicate-lang.org"))
+                                  (list (format "Hello ~a," email)
+                                        (format "")
+                                        (format "Here is your login link for Syndicate WebChat:")
+                                        (format "")
+                                        (format "    ~a" validation-url))))))))
+
+(define (spawn-login-link email sid)
+  (spawn #:name (list 'login-link email sid)
+         (on-start (log-info "Login link ~s for ~s activated." sid email))
+         (on-stop (log-info "Login link ~s for ~s deactivated." sid email))
+         (assert (login-link email sid))
+         (stop-when (asserted (session _ sid))) ;; happy path
+         (stop-when (message (end-session sid)))
+         (stop-when (message (delete-resource (account email))))
+         (stop-when-timeout (* (* 24 3600) 1000)))) ;; 24h = 1 day
+
+(define (login-link-emailed-page id maybe-insecure-validation-url)
+  (web-respond/pretty-xexpr!
+   id
+   (page "Syndicate Webchat"
+         (jumbotron "Login Link Emailed"
+                    (if maybe-insecure-validation-url
+                        `(p ((class "insecure-mode lead"))
+                            "INSECURE MODE: Click "
+                            (a ((href ,maybe-insecure-validation-url)) "here")
+                            " to log in")
+                        `(p ((class "lead"))
+                            "A login link should appear "
+                            "in your inbox shortly."))))))
+
+(spawn #:name 'login-link-page
+       (stop-when-reloaded)
+       ;; Can't handle the request within each login-link process, since we have to take
+       ;; special action if there is no such login link, and we are not allowed to race,
+       ;; meaning that this has to be a Single Point Of Control for making decisions based
+       ;; on the login-link relation.
+       (on (web-request-get (id req) _ ("login" (,$sid ())))
+           (match (immediate-query (query-value #f (login-link $email sid) email))
+             [#f (login-link-expired-page id)]
+             [email
+              (send! (create-resource (session email sid)))
+              (web-redirect! id "/" #:headers (list (format-cookie (session-id->cookie sid))))])))
+
+(define (login-link-expired-page id)
+  (web-respond/pretty-xexpr!
+   id
+   (page "Login Link Expired or Invalid"
+         (jumbotron "Login Link Expired or Invalid"
+                    `(p ((class "lead"))
+                        "Please " (a ((href "/")) "return to the main page") ".")))))
+
+(supervise
+ (spawn #:name 'session-monitor-factory
+        (stop-when-reloaded)
+        (on (message (create-resource ($ s (session $email $sid))))
+            (spawn #:name (list 'session-monitor email sid)
+                   (on-start (log-info "Session ~s for ~s started." sid email))
+                   (on-stop (log-info "Session ~s for ~s stopped." sid email))
+                   (assert s)
+                   (stop-when-duplicate s)
+                   (stop-when (message (delete-resource s)))
+                   (stop-when (message (delete-resource (account email))))
+                   (stop-when (message (end-session sid)))
+                   (stop-when-timeout (* 7 86400 1000)))))) ;; 1 week

examples/webchat/server/protocol.rkt

@@ -0,0 +1,173 @@
+#lang racket/base
+
+(provide (all-defined-out)) ;; TODO
+
+;; A Markup is a String containing very carefully-chosen extensions
+;; that allow a little bit of plain-text formatting without opening
+;; the system up to Cross-Site Scripting (XSS) vulnerabilities.
+
+;;---------------------------------------------------------------------------
+;; Server State
+
+;; (server-baseurl URLString)
+(struct server-baseurl (string) #:prefab) ;; ASSERTION
+
+;;---------------------------------------------------------------------------
+;; Session and Account Management
+
+;; (session EmailString String)
+;; Represents a live session. Retracted when the session ends.
+(struct session (email token) #:prefab) ;; ASSERTION
+
+;; (login-link EmailString String)
+;; Represents the availability of a non-expired login link. Retracted when the link expires.
+(struct login-link (email token) #:prefab) ;; ASSERTION
+
+;; (end-session String)
+;; Instructs any matching session to terminate.
+(struct end-session (token) #:prefab) ;; MESSAGE
+
+;; (account EmailString)
+;; Represents an extant account.
+(struct account (email) #:prefab) ;; ASSERTION
+
+;;---------------------------------------------------------------------------
+;; API requests and assertions
+
+;; (api Session Any)
+;; Represents some value asserted or transmitted on behalf of the
+;; given user session. Values of this type cannot be trusted, since
+;; they originate with the user's client, which may be the browser or
+;; may be some other client.
+(struct api (session value) #:prefab) ;; ASSERTION AND MESSAGE
+
+;;---------------------------------------------------------------------------
+;; Create, Update and Delete
+
+;; (create-resource Any)
+;; Request creation of the given resource as described.
+(struct create-resource (description) #:prefab) ;; MESSAGE
+
+;; (update-resource Any)
+;; Request update of the given resource as described.
+(struct update-resource (description) #:prefab) ;; MESSAGE
+
+;; (delete-resource Any)
+;; Request deletion of the given resource as described.
+(struct delete-resource (description) #:prefab) ;; MESSAGE
+
+;;---------------------------------------------------------------------------
+;; Capability Management
+
+;; A Principal is an EmailString
+
+;; TODO: Action: report a cap request as spam or some other kind of nuisance
+
+;; (grant Principal Principal Principal Any Boolean)
+;; Links in a grant chain.
+(struct grant (issuer grantor grantee permission delegable?) #:prefab) ;; ASSERTION
+
+;; (permitted Principal Principal Any Boolean)
+;; Net results of processing grant chains. Query these.
+(struct permitted (issuer email permission delegable?) #:prefab) ;; ASSERTION
+
+;; (permission-request Principal Principal Any)
+;; Represents an outstanding request for a permission.
+;; Satisfied by either - appearance of a matching Grant
+;;                     - receipt of a matching Revoke
+;;                     - receipt of a CancelRequest
+(struct permission-request (issuer grantee permission) #:prefab) ;; ASSERTION
+
+;;---------------------------------------------------------------------------
+;; Contact List Management
+
+;; M Capability to invite X to a conversation
+;; W Capability to see onlineness of X
+;; W Capability to silently block X from contacting one in any way
+;; W Capability to visibly block X from contacting one in any way
+;; W Capability to mute an individual outside the context of any particular conversation for a certain length of time
+
+;; (contact-list-entry Principal Principal)
+;; Asserts that `member` is a member of the contact list owned by `owner`.
+(struct contact-list-entry (owner member) #:prefab) ;; ASSERTION
+
+;; (p:follow Principal)
+;; When (permitted X Y (p:follow X) _), X says that Y may follow X.
+(struct p:follow (email) #:prefab)
+
+;; (struct p:invite (email) #:prefab)
+;; (struct p:see-presence (email) #:prefab)
+
+;;---------------------------------------------------------------------------
+;; Conversation Management
+
+;; M Capability to destroy a conversation
+;; M Capability to invite someone inviteable to a conversation
+;; M Capability to cancel an open invitation
+;; M Capability to boot someone from a conversation
+;; M Capability to leave a conversation
+;; M Capability to reject an invitation to a conversation
+;; M Capability to accept an invitation to a conversation
+;; M Capability to see the list of participants in a conversation
+;; M Capability to publish posts to a conversation
+;; S Capability to remove or edit one's own posts
+;; S Capability to remove or edit other people's posts
+;; C Capability to clear conversation history
+;; C Capability to react to a post on a conversation
+;; W Capability to delegate capabilities to others
+;; W Capability to mute a conversation for a certain length of time
+;; W Capability to mute an individual within the context of a particular conversation for a certain length of time
+;; W Capability to have a conversation joinable by ID, without an invitation
+;; W Capability to have a conversation be publicly viewable
+;; W Capability to draft posts before publication
+;; W Capability to approve draft posts
+
+;; TODO: For now, all members will have all conversation control
+;; abilities. Later, these can be split out into separate permissions.
+
+;; Attribute: conversation title
+;; Attribute: conversation creator
+;; Attribute: conversation blurb
+;; Attribute: conversation members
+
+;; Simple posting is a combination of draft+approve.
+;; Flagging a post for moderator attention is a kind of reaction.
+
+;; (conversation String String Principal Markup Boolean
+(struct conversation (id title creator blurb) #:prefab) ;; ASSERTION
+
+;; (invitation String Principal Principal)
+(struct invitation (conversation-id inviter invitee) #:prefab) ;; ASSERTION
+
+;; (in-conversation String Principal)
+;; Records conversation membership.
+(struct in-conversation (conversation-id member) #:prefab) ;; ASSERTION
+
+(struct post (id ;; String
+              timestamp ;; Seconds
+              conversation-id ;; String
+              author ;; Principal
+              items ;; Listof DataURLString
+              ) #:prefab) ;; ASSERTION
+
+;;---------------------------------------------------------------------------
+;; User Interaction
+
+;; (ui-template String String)
+;; A fragment of HTML for use in the web client.
+(struct ui-template (name data) #:prefab) ;; ASSERTION
+
+;; (question String Seconds String Principal String Markup QuestionType)
+(struct question (id timestamp class target title blurb type) #:prefab) ;; ASSERTION
+
+;; (answer String Any)
+(struct answer (id value) #:prefab) ;; MESSAGE
+
+;; A QuestionType is one of
+;; - (yes/no-question Markup Markup)
+;; - (option-question (Listof (List Any Markup)))
+;; - (text-question Boolean)
+(struct yes/no-question (false-value true-value) #:prefab)
+(struct option-question (options) #:prefab)
+(struct text-question (multiline?) #:prefab)
+(struct acknowledge-question () #:prefab)

examples/webchat/server/qa.rkt

@@ -0,0 +1,41 @@
+#lang syndicate
+
+(provide ask-question!)
+
+(require racket/port)
+(require markdown)
+
+(require/activate syndicate/reload)
+(require/activate syndicate/supervise)
+
+(require "protocol.rkt")
+(require "util.rkt")
+
+(supervise
+ (spawn #:name 'qa-relay
+        (stop-when-reloaded)
+        (during ($ q (question _ _ _ _ _ _ _))
+          (define qid (question-id q))
+          (define target (question-target q))
+          (assert (api (session target _) q))
+          (during (api (session target _) (answer qid $value))
+            (assert (answer qid value))))))
+
+(define (ask-question! #:title title
+                       #:blurb blurb
+                       #:class [q-class "q-generic"]
+                       #:target target
+                       question-type)
+  (define qid (random-hex-string 32))
+  (define q (question qid
+                      (current-seconds)
+                      q-class
+                      target
+                      title
+                      (with-output-to-string
+                        (lambda ()
+                          (display-xexpr blurb)))
+                      question-type))
+  (assert q)
+  qid)
+

examples/webchat/server/run

@@ -0,0 +1,5 @@
+#!/bin/sh
+SYNDICATE_TRACE=${SYNDICATE_TRACE:-_}
+SYNDICATE_STDOUT_TO_STDERR=y
+export SYNDICATE_TRACE SYNDICATE_STDOUT_TO_STDERR
+exec racketmake main.rkt -f testing.rktd 2>&1 | tai64n | tai64nlocal

examples/webchat/server/script-compiler.rkt

@@ -0,0 +1,25 @@
+#lang syndicate
+
+(require racket/file)
+(require racket/port)
+(require racket/system)
+
+(require/activate syndicate/reload)
+(require/activate syndicate/drivers/filesystem)
+(require/activate syndicate/drivers/web)
+
+(spawn #:name 'script-compiler
+       (stop-when-reloaded)
+       (define source-filename "../htdocs/webchat.syndicate.js")
+       (define target-filename "webchat.js")
+       (during/spawn (file-content source-filename file->bytes $bs)
+         #:name (list 'compiled source-filename)
+         (define compiled (with-output-to-bytes
+                            (lambda () (system* "../../../js/bin/syndicatec" source-filename))))
+         (log-info "Finished compiling ~s" target-filename)
+         (on (web-request-get (id req) _ (,target-filename ()))
+             (web-respond/bytes! id
+                                 #:header (web-response-header
+                                           #:headers (list (cons 'content-type
+                                                                 "application/javascript")))
+                                 compiled))))

examples/webchat/server/session-cookie.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+
+(provide COOKIE
+         clear-session-cookie
+         format-cookie
+         fresh-session-id
+         session-id->cookie
+         with-session)
+
+(require racket/list)
+(require racket/match)
+(require racket/set)
+(require web-server/http/request-structs)
+(require web-server/http/cookie)
+
+(require syndicate/actor)
+(require syndicate/drivers/web)
+
+(require "protocol.rkt")
+(require "util.rkt")
+
+(define COOKIE "syndicatewebchat")
+
+(define clear-session-cookie (make-cookie COOKIE
+                                          ""
+                                          #:path "/"
+                                          #:expires "Thu, 01 Jan 1970 00:00:00 GMT"))
+
+(define (format-cookie c)
+  (match-define (header field value) (cookie->header c))
+  (cons (string->symbol (string-downcase (bytes->string/latin-1 field)))
+        (bytes->string/utf-8 value)))
+
+(define (fresh-session-id)
+  (random-hex-string 32))
+
+(define (session-id->cookie sid)
+  (make-cookie COOKIE sid #:path "/"))
+
+(define-syntax with-session
+  (syntax-rules (else)
+    [(_ id [(email sid) body ...])
+     (with-session id [(email sid) body ...] [else (web-redirect! id "/")])]
+    [(_ id [(email sid) body ...] [else no-session-body ...])
+     (let ()
+       (define (on-no-session)
+         no-session-body ...)
+       (match (immediate-query (query-value #f (web-request-cookie id COOKIE $v _ _) v))
+         [#f (on-no-session)]
+         [sid
+          (match (immediate-query (query-value #f (session $e sid) e))
+            [#f (on-no-session)]
+            [email
+             body ...])]))]))

examples/webchat/server/static-content.rkt

@@ -0,0 +1,45 @@
+#lang syndicate
+
+(require racket/file)
+(require racket/runtime-path)
+(require net/url)
+(require web-server/dispatchers/filesystem-map)
+(require web-server/private/mime-types)
+
+(require "protocol.rkt")
+
+(require/activate syndicate/reload)
+(require/activate syndicate/drivers/filesystem)
+(require/activate syndicate/drivers/web)
+
+(begin-for-declarations
+  (define-runtime-path htdocs-path "../htdocs")
+  (define-runtime-path templates-path "../htdocs/templates")
+  (define-runtime-path syndicate-js-dist-path "../../../js/dist")
+  (define path->mime-type (make-path->mime-type "/etc/mime.types")))
+
+(spawn #:name 'static-content-server
+       (stop-when-reloaded)
+       (define static-paths (list htdocs-path syndicate-js-dist-path))
+       (define url->path-fns (map make-url->path static-paths))
+       (define (url->existing-static-path u)
+         (for/or [(url->path (in-list url->path-fns))]
+           (define-values (path path-pieces) (url->path u))
+           (and (file-exists? path) path)))
+       (on (web-request-get (id req) _ ,_)
+           (define path (url->existing-static-path
+                         (resource->url (web-request-header-resource req))))
+           (when path
+             (web-respond/bytes! id
+                                 #:header (web-response-header #:mime-type (path->mime-type path))
+                                 (file->bytes path)))))
+
+(spawn #:name 'template-server
+       (stop-when-reloaded)
+       (define url->path (make-url->path templates-path))
+       (during (api _ (observe (ui-template $name _)))
+         (define-values (path path-pieces) (url->path (string->url name)))
+         (on-start (log-info "Start observation of ~v" path))
+         (on-stop (log-info "Stop observation of ~v" path))
+         (during (file-content path file->string $data)
+           (assert (api _ (ui-template name data))))))

examples/webchat/server/testdata.rkt

@@ -0,0 +1,23 @@
+#lang syndicate
+
+(require "protocol.rkt")
+
+(send! (create-resource (account "tonyg@ccs.neu.edu")))
+(send! (create-resource (account "me@here")))
+(send! (create-resource (account "also@here")))
+
+(define (follow! A B)
+  (send! (create-resource (grant A A B (p:follow A) #f)))
+  (send! (create-resource (grant B B A (p:follow B) #f))))
+
+(follow! "tonyg@ccs.neu.edu" "me@here")
+(follow! "also@here" "me@here")
+(follow! "tonyg@ccs.neu.edu" "also@here")
+
+(define (make-conversation! cid title creator . other-members)
+  (send! (create-resource (conversation cid title creator "")))
+  (for [(who (in-list (cons creator other-members)))]
+    (send! (create-resource (in-conversation cid who)))))
+
+(make-conversation! "test" "Test Conversation" "tonyg@ccs.neu.edu" "me@here")
+(make-conversation! "grouptest" "Group Conversation" "also@here" "me@here" "tonyg@ccs.neu.edu")

examples/webchat/server/trust.rkt

@@ -0,0 +1,51 @@
+#lang syndicate
+
+(require racket/set)
+
+(require/activate syndicate/reload)
+(require "protocol.rkt")
+(require "duplicate.rkt")
+
+(spawn #:name 'trust-inference
+       (stop-when-reloaded)
+
+       (during (grant $issuer $grantor $grantee $permission $delegable?)
+         (when (equal? issuer grantor)
+           (assert (permitted issuer grantee permission delegable?)))
+         (during (permitted issuer grantor permission #t)
+           (assert (permitted issuer grantee permission delegable?)))))
+
+(spawn #:name 'grant-factory
+       (stop-when-reloaded)
+       (on (message (create-resource
+                     ($ g (grant $issuer $grantor $grantee $permission $delegable?))))
+           (spawn #:name g
+                  (on-start (log-info "~s grants ~s ~v~a"
+                                      grantor grantee permission (if delegable? ", delegably" "")))
+                  (on-stop (log-info "~s revokes~a grant of ~v to ~s"
+                                     grantor (if delegable? " delegable" "") permission grantee))
+                  (assert g)
+                  (stop-when-duplicate g)
+                  (stop-when (message (delete-resource g)))
+                  (stop-when (message
+                              (delete-resource (permitted issuer grantee permission delegable?))))
+                  (stop-when (message (delete-resource (account issuer))))
+                  (stop-when (message (delete-resource (account grantor))))
+                  (stop-when (message (delete-resource (account grantee)))))))
+
+(spawn #:name 'request-factory
+       (stop-when-reloaded)
+       (on (message (create-resource ($ r (permission-request $the-issuer $grantee $permission))))
+           (spawn #:name r
+                  (on-start (log-info "~s requests ~s from ~s" grantee permission the-issuer))
+                  (assert r)
+                  (stop-when-duplicate r)
+                  (stop-when (message (delete-resource r))
+                             (log-info "~s's request of ~s from ~s was cancelled or denied"
+                                       grantee permission the-issuer))
+                  (stop-when (asserted (permitted the-issuer grantee permission $delegable?))
+                             (log-info "~s's request of ~s from ~s was approved~a"
+                                       grantee
+                                       permission
+                                       the-issuer
+                                       (if delegable? ", delegably" ""))))))

examples/webchat/server/util.rkt

@@ -0,0 +1,9 @@
+#lang racket/base
+
+(provide random-hex-string)
+
+(require (only-in file/sha1 bytes->hex-string))
+(require (only-in racket/random crypto-random-bytes))
+
+(define (random-hex-string half-length)
+  (bytes->hex-string (crypto-random-bytes half-length)))

hs/src/Syndicate/Dataspace/Trie/Prefix.hs

@@ -39,8 +39,6 @@ route ('<' : nc : s) (Br (os, w, _)) f =
       Nothing -> route s (makeTail n w) f
 route (x : s) (Br (_, w, h)) f = route s (Map.findWithDefault w x h) f
 
-get w h x = Map.findWithDefault w x h
-
 combine f leftEmpty rightEmpty r1 r2 = g r1 r2
     where g (Ok v) r2 = f (Ok v) r2
           g r1 (Ok v) = f r1 (Ok v)
@@ -56,7 +54,7 @@ foldKeys g (Br (os1, w1, h1)) (Br (os2, w2, h2)) =
                         let o2 = Map.findWithDefault (makeTail size w2) size os2 in
                         let o = g o1 o2 in
                         if stripTail size o == Just w then acc else Map.insert size o acc
-          f x acc = update x (g (get w1 h1 x) (get w2 h2 x)) w acc
+          f x acc = update x (g (Map.findWithDefault w1 x h1) (Map.findWithDefault w2 x h2)) w acc
           keys = Set.union (Map.keysSet h1) (Map.keysSet h2)
 
 collapse (Br (os, Mt, h)) | Map.null os && Map.null h = empty

js/compiler/compiler.js

@@ -55,9 +55,9 @@ function buildActor(nameExpOpt, block, withReact) {
 }
 
 function reactWrap(blockCode) {
-  return '{ Syndicate.Actor.Facet.build((function () { ' +
+  return '{ Syndicate.Actor.Facet.build(function () { ' +
     blockCode +
-    ' }).bind(this)); }';
+    ' }); }';
 }
 
 function buildOnEvent(isTerminal, eventType, subscription, projection, bindings, body) {
@@ -86,10 +86,10 @@ function buildCaseEvent(eventPattern, body) {
 }
 
 var modifiedSourceActions = {
-  ActorStatement_noReact: function(_actorStar, _namedOpt, nameExpOpt, block) {
+  ActorStatement_noReact: function(_spawnStar, _namedOpt, nameExpOpt, block) {
     return buildActor(nameExpOpt, block, false);
   },
-  ActorStatement_withReact: function(_actor, _namedOpt, nameExpOpt, block) {
+  ActorStatement_withReact: function(_spawn, _namedOpt, nameExpOpt, block) {
     return buildActor(nameExpOpt, block, true);
   },
 
@@ -197,7 +197,7 @@ var modifiedSourceActions = {
                                                [],
                                                '{}')) + '}');
   },
-  ActorEndpointStatement_duringActor: function(_during, pattern, _actor, _named, nameExpOpt, block)
+  ActorEndpointStatement_duringSpawn: function(_during, pattern, _spawn, _named, nameExpOpt, block)
   {
     var cachedAssertionVar = gensym('cachedAssertion');
     var actorBlock = {

js/compiler/demo-bad-this.js

@@ -0,0 +1,59 @@
+// bin/syndicatec compiler/demo-bad-this.js | node
+//
+// Bug with this-ness. Symptomatic output:
+//
+// + render one false
+// + render two false
+// present one
+// - render one false
+// - render two false
+// + render one one
+// + render two one
+//
+// Good output:
+//
+// + render one false
+// + render two false
+// present one
+// - render one false
+// + render one one
+
+var Syndicate = require('./src/main.js');
+
+assertion type user(who);
+assertion type present(who);
+assertion type rendered(who, isPresent);
+
+ground dataspace {
+  spawn {
+    assert user('one');
+    assert present('one');
+  }
+
+  spawn {
+    assert user('two');
+    // assert present('two');
+  }
+
+  spawn {
+    during user($who) {
+      field this.isPresent = false;
+      on asserted present(who) {
+        console.log('present', who);
+        this.isPresent = who;
+      }
+      on retracted present(who) {
+        console.log('absent', who);
+        this.isPresent = false;
+      }
+      assert rendered(who, this.isPresent);
+    }
+  }
+
+  spawn {
+    during rendered($who, $isPresent) {
+      on start { console.log('+ render', who, isPresent); }
+      on stop { console.log('- render', who, isPresent); }
+    }
+  }
+}

js/compiler/demo-bankaccount.js

@@ -6,7 +6,7 @@ assertion type account(balance);
 message type deposit(amount);
 
 ground dataspace {
-  actor {
+  spawn {
     field this.balance = 0;
     assert account(this.balance);
     dataflow {
@@ -17,13 +17,13 @@ ground dataspace {
     }
   }
 
-  actor {
+  spawn {
     on asserted account($balance) {
       console.log("Balance is now", balance);
     }
   }
 
-  actor {
+  spawn {
     on start {
       console.log("Waiting for account.");
     }

js/compiler/demo-during-criterion-snapshotting.js

@@ -19,7 +19,7 @@ var Dataspace = Syndicate.Dataspace;
 assertion type foo(x, y);
 
 ground dataspace {
-  actor {
+  spawn {
     field this.x = 123;
 
     assert foo(this.x, 999);

js/compiler/demo-filesystem.js

@@ -22,7 +22,7 @@ ground dataspace {
   ///////////////////////////////////////////////////////////////////////////
   // The file system actor
 
-  actor {
+  spawn {
     this.files = {};
     during Syndicate.observe(file($name, _)) {
       on start {
@@ -44,7 +44,7 @@ ground dataspace {
   ///////////////////////////////////////////////////////////////////////////
   // A simple demo client of the file system
 
-  actor {
+  spawn {
     on asserted file("hello.txt", $content) {
       console.log("hello.txt has content", JSON.stringify(content));
     }
@@ -54,14 +54,14 @@ ground dataspace {
     }
   }
 
-  actor {
+  spawn {
     stop on asserted Syndicate.observe(saveFile(_, _)) {
       :: saveFile("hello.txt", "a");
       :: deleteFile("hello.txt");
       :: saveFile("hello.txt", "c");
       :: saveFile("hello.txt", "quit demo");
       :: saveFile("hello.txt", "final contents");
-      actor {
+      spawn {
         stop on asserted file("hello.txt", $content) {
           console.log("second observer sees that hello.txt content is",
                       JSON.stringify(content));

js/compiler/demo-nested-during.js

@@ -59,7 +59,7 @@ assertion type show();
 assertion type view(str);
 
 ground dataspace {
-  actor {
+  spawn {
     field this.title = "first";
     assert todo(this.title);
     on message 3 {
@@ -67,11 +67,11 @@ ground dataspace {
     }
   }
 
-  actor {
+  spawn {
     assert show();
   }
 
-  actor {
+  spawn {
     field this.editing = false;
 
     during todo($title) {
@@ -95,14 +95,14 @@ ground dataspace {
     }
   }
 
-  actor {
+  spawn {
     on start { :: 0; }
     stop on message 0 {
       :: 1;
     }
   }
 
-  actor {
+  spawn {
     field this.count = 0;
     on retracted view($x) { console.log('VIEW--', x); }
     on asserted view($x) {

js/compiler/demo-proper-interest-tracking.js

@@ -14,7 +14,7 @@ assertion type ready(what);
 assertion type entry(key, val);
 
 ground dataspace {
-  actor named 'listener' {
+  spawn named 'listener' {
     assert ready('listener');
     on asserted entry($key, _) {
       console.log('key asserted', key);
@@ -28,7 +28,7 @@ ground dataspace {
     }
   }
 
-  actor named 'other-listener' {
+  spawn named 'other-listener' {
     assert ready('other-listener');
     during entry($key, _) {
       on start { console.log('(other-listener) key asserted', key); }
@@ -50,7 +50,7 @@ ground dataspace {
     }
   }
 
-  actor named 'driver' {
+  spawn named 'driver' {
     stop on asserted ready('listener') {
       react {
         stop on asserted ready('other-listener') {

js/compiler/demo-synthetic-patch-2.js

@@ -0,0 +1,55 @@
+// bin/syndicatec compiler/demo-synthetic-patch-2.js | node
+//
+// Analogous example to syndicate/racket/syndicate/examples/actor/example-synthetic-patch-2.rkt.
+//
+// Symptomatic output:
+//
+// Outer value 4 = 4
+// Value 0 = 0
+// Value 1 = 1
+// Value 2 = 2
+// Value 3 = 3
+//
+// Correct output:
+//
+// Outer value 4 = 4
+// Value 0 = 0
+// Value 1 = 1
+// Value 2 = 2
+// Value 3 = 3
+// Value 4 = 4
+// Value 5 = 5
+
+var Syndicate = require('./src/main.js');
+
+assertion type mapping(key, value);
+assertion type ready();
+
+ground dataspace {
+  spawn {
+    field this.ofInterest = 0;
+    during ready() {
+      on asserted mapping(this.ofInterest, $v) {
+        console.log("Value", this.ofInterest, "=", v);
+        this.ofInterest += 1;
+      }
+    }
+    on asserted mapping(4, $v) {
+      console.log("Outer value", 4, "=", v);
+    }
+  }
+
+  spawn {
+    assert mapping(0, 0);
+    assert mapping(1, 1);
+    assert mapping(2, 2);
+    assert mapping(3, 3);
+    assert mapping(4, 4);
+    assert mapping(5, 5);
+    on start {
+      react {
+        assert ready();
+      }
+    }
+  }
+}

js/compiler/syndicate.ohm

@@ -18,8 +18,8 @@ Syndicate <: ES5 {
   FunctionBodyBlock = "{" FunctionBody "}"   // odd that this isn't in es5.ohm somewhere
 
   ActorStatement
-    = actorStar (named Expression<withIn>)? FunctionBodyBlock -- noReact
-    | actor (named Expression<withIn>)? FunctionBodyBlock     -- withReact
+    = spawnStar (named Expression<withIn>)? FunctionBodyBlock -- noReact
+    | spawn (named Expression<withIn>)? FunctionBodyBlock     -- withReact
 
   DataspaceStatement
     = ground dataspace identifier? FunctionBodyBlock -- ground
@@ -38,7 +38,7 @@ Syndicate <: ES5 {
     | stop on FacetTransitionEventPattern #(sc)                               -- stopOnNoCont
     | dataflow FunctionBodyBlock                                              -- dataflow
     | during FacetPattern FunctionBodyBlock                                   -- during
-    | during FacetPattern actor (named Expression<withIn>)? FunctionBodyBlock -- duringActor
+    | during FacetPattern spawn (named Expression<withIn>)? FunctionBodyBlock -- duringSpawn
 
   AssertWhenClause = when "(" Expression<withIn> ")"
 
@@ -69,8 +69,8 @@ Syndicate <: ES5 {
   // we don't want to make them unavailable to programs as
   // identifiers.
 
-  actorStar = "actor*" ~identifierPart
-  actor = "actor" ~("*" | identifierPart)
+  spawnStar = "spawn*" ~identifierPart
+  spawn = "spawn" ~("*" | identifierPart)
   assert = "assert" ~identifierPart
   asserted = "asserted" ~identifierPart
   assertion = "assertion" ~identifierPart

js/examples/button/index.js

@@ -1,7 +1,7 @@
 ground dataspace {
   Syndicate.UI.spawnUIDriver();
 
-  actor {
+  spawn {
     var ui = new Syndicate.UI.Anchor();
     field this.counter = 0;
     assert ui.html('#button-label', '' + this.counter);

js/examples/chat/index.js

@@ -15,7 +15,7 @@ function spawnChatApp() {
   $("#nym_form").submit(function (e) { e.preventDefault(); return false; });
   if (!($("#nym").val())) { $("#nym").val("nym" + Math.floor(Math.random() * 65536)); }
 
-  actor {
+  spawn {
     var ui = new Syndicate.UI.Anchor();
     field this.nym;
     field this.status;
@@ -82,8 +82,8 @@ function outputUtterance(who, what) {
 assertion type inputValue(selector, value);
 
 function spawnInputChangeMonitor() {
-  actor {
-    during Syndicate.observe(inputValue($selector, _)) actor {
+  spawn {
+    during Syndicate.observe(inputValue($selector, _)) spawn {
       field this.value = $(selector).val();
       assert inputValue(selector, this.value);
       on message Syndicate.UI.globalEvent(selector, 'change', $e) {

js/examples/dom-webworker/Makefile

@@ -0,0 +1,7 @@
+all: index.expanded.js worker.expanded.js
+
+%.expanded.js: %.js
+	../../bin/syndicatec $< > $@ || (rm -f $@; false)
+
+clean:
+	rm -f *.expanded.js