syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Compare commits

base: syndicate-lang:main
Branches Tags
syndicate-lang:main
syndicate-lang:pr/45
syndicate-lang:wip-typedefs
syndicate-lang:gh-pages
syndicate-lang:pr/43
syndicate-lang:pr/42
syndicate-lang:behav
syndicate-lang:pr/37
syndicate-lang:imperative
syndicate-lang:typed
syndicate-lang:module-begin
syndicate-lang:pr/34
syndicate-lang:pr/32
syndicate-lang:upside-down
syndicate-lang:spawn/actor-swap
syndicate-lang:functional-dataflow-impl
syndicate-lang:tui
syndicate-lang:attributed-action
syndicate-lang:render_dataspace
syndicate-lang:hll-syndicate-racket-v1
syndicate-lang:platformer_hll_tmp
syndicate-lang:pr/14
syndicate-lang:concurrent_actors
syndicate-lang:comprehensions
syndicate-lang:pr/9
syndicate-lang:pr/8
syndicate-lang:pr/7
syndicate-lang:pr/1
syndicate-lang:bitset
syndicate-lang:canonical-sets
syndicate-lang:extracted_imperative_syndicate_20200427
syndicate-lang:last_route_rkt_pre_trie_rkt
syndicate-lang:places-2016
..
compare: syndicate-lang:render_dataspace
Branches Tags
syndicate-lang:main
syndicate-lang:pr/45
syndicate-lang:wip-typedefs
syndicate-lang:gh-pages
syndicate-lang:pr/43
syndicate-lang:pr/42
syndicate-lang:behav
syndicate-lang:pr/37
syndicate-lang:imperative
syndicate-lang:typed
syndicate-lang:module-begin
syndicate-lang:pr/34
syndicate-lang:pr/32
syndicate-lang:upside-down
syndicate-lang:spawn/actor-swap
syndicate-lang:functional-dataflow-impl
syndicate-lang:tui
syndicate-lang:attributed-action
syndicate-lang:render_dataspace
syndicate-lang:hll-syndicate-racket-v1
syndicate-lang:platformer_hll_tmp
syndicate-lang:pr/14
syndicate-lang:concurrent_actors
syndicate-lang:comprehensions
syndicate-lang:pr/9
syndicate-lang:pr/8
syndicate-lang:pr/7
syndicate-lang:pr/1
syndicate-lang:bitset
syndicate-lang:canonical-sets
syndicate-lang:extracted_imperative_syndicate_20200427
syndicate-lang:last_route_rkt_pre_trie_rkt
syndicate-lang:places-2016

1 Commits
main ... render_dat

Author SHA1 Message Date
Tony Garnock-Jones acf5db57f8 Fiddle with visualization of assertion flow 2016-07-31 23:53:50 -04:00
476 changed files with 4529 additions and 35074 deletions
Show Stats Expand all files Collapse all files

17
README.md
View File

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

2
examples/ircd/.gitignore vendored
View File

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

7
examples/ircd/Makefile
View File

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

17
examples/ircd/TODO.md
View File

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

24
examples/ircd/channel.rkt
View File

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

14
examples/ircd/config.rkt
View File

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

7
examples/ircd/main.rkt
View File

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

93
examples/ircd/message.rkt
View File

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

30
examples/ircd/protocol.rkt
View File

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

177
examples/ircd/session.rkt
View File

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

5
examples/netstack/incremental-highlevel/Makefile
View File

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

13
examples/netstack/README.md → examples/netstack/incremental-highlevel/README.md
View File

@ -1,18 +1,5 @@
# TCP/IP Stack # TCP/IP Stack
There are two (closely-related) implementations here:
- [`monolithic-lowlevel`](monolithic-lowlevel/) is the original
implementation, originally written for `minimart`, a language that
followed our ESOP 2014 paper quite closely. Porting it to a
monolithic-assertion-set Syndicate dialect helped substantially
simplify the code.
- [`incremental-highlevel`](incremental-highlevel/) is a port of
`monolithic-lowlevel` to the Syndicate high-level DSL
("`syndicate/actor`"). Moving from the low-level Syndicate style to
the high-level style also drastically simplified the code.
## Linux Firewall Configuration ## Linux Firewall Configuration
Imagine a setup where the machine you are running this code has IP Imagine a setup where the machine you are running this code has IP

6
examples/netstack/TODO.md → examples/netstack/incremental-highlevel/TODO.md
View File

@ -11,14 +11,8 @@ TCP options negotiation.
- SACK - SACK
- Window scaling - Window scaling
Check that we handle the situations in figs. 9, 10, 11, pp.33- of RFC 793.
Bugs: Bugs:
- RST kills a connection even if its sequence number is bogus. Check - RST kills a connection even if its sequence number is bogus. Check
to make sure it's in the window. (See to make sure it's in the window. (See
http://static.googleusercontent.com/media/research.google.com/en//pubs/archive/41848.pdf http://static.googleusercontent.com/media/research.google.com/en//pubs/archive/41848.pdf
and RFC 5961) and RFC 5961)
Conform better to the rules for reset generation and processing
from pp.36- of RFC 793. In particular, do not blindly accept RSTs
without checking sequence numbers against windows etc.

20
examples/netstack/incremental-highlevel/arp.rkt
View File

@ -1,4 +1,4 @@
#lang syndicate #lang syndicate/actor
;; ARP protocol, http://tools.ietf.org/html/rfc826 ;; ARP protocol, http://tools.ietf.org/html/rfc826
;; Only does ARP-over-ethernet. ;; Only does ARP-over-ethernet.
@ -29,15 +29,15 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-arp-driver) (define (spawn-arp-driver)
(spawn #:name 'arp-driver (actor #:name 'arp-driver
(during/spawn (arp-interface $interface-name) (react (during/actor (arp-interface $interface-name)
#:name (list 'arp-interface interface-name) #:name (list 'arp-interface interface-name)
(assert (arp-interface-up interface-name)) (assert (arp-interface-up interface-name))
(on-start (define hwaddr (lookup-ethernet-hwaddr interface-name)) (on-start (define hwaddr (lookup-ethernet-hwaddr interface-name))
(when (not hwaddr) (when (not hwaddr)
(error 'arp "Failed to look up ARP interface ~v" (error 'arp "Failed to look up ARP interface ~v"
interface-name)) interface-name))
(react (run-arp-interface interface-name hwaddr)))))) (react (run-arp-interface interface-name hwaddr)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

219
examples/netstack/incremental-highlevel/cpingresp.c
View File

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

30
examples/netstack/incremental-highlevel/demo-config.rkt
View File

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

66
examples/netstack/incremental-highlevel/ethernet.rkt
View File

@ -1,4 +1,4 @@
#lang syndicate #lang syndicate/actor
;; Ethernet driver ;; Ethernet driver
(provide (struct-out ethernet-packet) (provide (struct-out ethernet-packet)
@ -29,44 +29,44 @@
(log-info "Device names: ~a" interface-names) (log-info "Device names: ~a" interface-names)
(define (spawn-ethernet-driver) (define (spawn-ethernet-driver)
(spawn #:name 'ethernet-driver (actor #:name 'ethernet-driver
(during/spawn (react (during/actor
(observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _)) (observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _))
#:name (list 'ethernet-interface interface-name) #:name (list 'ethernet-interface interface-name)
(define h (raw-interface-open interface-name)) (define h (raw-interface-open interface-name))
(when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name)) (when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
(log-info "Opened interface ~a, yielding handle ~v" interface-name h) (log-info "Opened interface ~a, yielding handle ~v" interface-name h)
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h))) (define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
(assert interface) (assert interface)
(define control-ch (make-async-channel)) (define control-ch (make-async-channel))
(thread (lambda () (interface-packet-read-loop interface h control-ch))) (thread (lambda () (interface-packet-read-loop interface h control-ch)))
(on-start (flush!) ;; ensure all subscriptions are in place (on-start (flush!) ;; ensure all subscriptions are in place
(async-channel-put control-ch 'unblock) (async-channel-put control-ch 'unblock)
(spawn #:name (list 'ethernet-interface-quit-monitor interface-name) (actor #:name (list 'ethernet-interface-quit-monitor interface-name)
(on (retracted interface) (react (on (retracted interface)
(async-channel-put control-ch 'quit)))) (async-channel-put control-ch 'quit)))))
(on (message (inbound ($ p (ethernet-packet interface #t _ _ _ _)))) (on (message (inbound ($ p (ethernet-packet interface #t _ _ _ _))))
;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)" ;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
;; (ethernet-interface-name (ethernet-packet-interface p)) ;; (ethernet-interface-name (ethernet-packet-interface p))
;; (pretty-bytes (ethernet-packet-source p)) ;; (pretty-bytes (ethernet-packet-source p))
;; (pretty-bytes (ethernet-packet-destination p)) ;; (pretty-bytes (ethernet-packet-destination p))
;; (number->string (ethernet-packet-ethertype p) 16)) ;; (number->string (ethernet-packet-ethertype p) 16))
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
(send! p)) (send! p))
(on (message ($ p (ethernet-packet interface #f _ _ _ _))) (on (message ($ p (ethernet-packet interface #f _ _ _ _)))
;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)" ;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
;; (ethernet-interface-name (ethernet-packet-interface p)) ;; (ethernet-interface-name (ethernet-packet-interface p))
;; (pretty-bytes (ethernet-packet-source p)) ;; (pretty-bytes (ethernet-packet-source p))
;; (pretty-bytes (ethernet-packet-destination p)) ;; (pretty-bytes (ethernet-packet-destination p))
;; (number->string (ethernet-packet-ethertype p) 16)) ;; (number->string (ethernet-packet-ethertype p) 16))
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
(raw-interface-write h (encode-ethernet-packet p)))))) (raw-interface-write h (encode-ethernet-packet p)))))))
(define (interface-packet-read-loop interface h control-ch) (define (interface-packet-read-loop interface h control-ch)
(define (blocked) (define (blocked)

23
examples/netstack/incremental-highlevel/fetchurl.rkt
View File

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

45
examples/netstack/incremental-highlevel/ip.rkt
View File

@ -1,4 +1,4 @@
#lang syndicate #lang syndicate/actor
(provide (struct-out ip-packet) (provide (struct-out ip-packet)
ip-address->hostname ip-address->hostname
@ -57,17 +57,18 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-ip-driver) (define (spawn-ip-driver)
(spawn #:name 'ip-driver (actor #:name 'ip-driver
(during/spawn (host-route $my-address $netmask $interface-name) (react
(assert (route-up (host-route my-address netmask interface-name))) (during/actor (host-route $my-address $netmask $interface-name)
(do-host-route my-address netmask interface-name)) (assert (route-up (host-route my-address netmask interface-name)))
(during/spawn (gateway-route $network $netmask $gateway-addr $interface-name) (do-host-route my-address netmask interface-name))
(assert (route-up (during/actor (gateway-route $network $netmask $gateway-addr $interface-name)
(gateway-route $network $netmask $gateway-addr $interface-name))) (assert (route-up
(do-gateway-route network netmask gateway-addr interface-name)) (gateway-route $network $netmask $gateway-addr $interface-name)))
(during/spawn (net-route $network-addr $netmask $link) (do-gateway-route network netmask gateway-addr interface-name))
(assert (route-up (net-route network-addr netmask link))) (during/actor (net-route $network-addr $netmask $link)
(do-net-route network-addr netmask link)))) (assert (route-up (net-route network-addr netmask link)))
(do-net-route network-addr netmask link)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Local IP route ;; Local IP route
@ -176,22 +177,20 @@
(when (and (not (equal? (ip-packet-source-interface p) interface-name)) (when (and (not (equal? (ip-packet-source-interface p) interface-name))
(ip-address-in-subnet? destination network netmask)) (ip-address-in-subnet? destination network netmask))
(define timer-id (gensym 'ippkt)) (define timer-id (gensym 'ippkt))
;; v Use `spawn` instead of `react` to avoid gratuitous packet (react (on-start (send! (set-timer timer-id 5000 'relative)))
;; reordering.
(spawn (on-start (send! (set-timer timer-id 5000 'relative)))
(stop-when (message (timer-expired timer-id _)) (stop-when (message (timer-expired timer-id _))
(log-warning "ARP lookup of ~a failed, packet dropped" (log-warning "ARP lookup of ~a failed, packet dropped"
(ip-address->hostname destination))) (ip-address->hostname destination)))
(stop-when (asserted (arp-query IPv4-ethertype (stop-when (asserted (arp-query IPv4-ethertype
destination destination
($ interface (ethernet-interface interface-name _)) ($ interface (ethernet-interface interface-name _))
$destination-hwaddr)) $destination-hwaddr))
(send! (ethernet-packet interface (send! (ethernet-packet interface
#f #f
(ethernet-interface-hwaddr interface) (ethernet-interface-hwaddr interface)
destination-hwaddr destination-hwaddr
IPv4-ethertype IPv4-ethertype
(format-ip-packet p)))))))) (format-ip-packet p))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

100
examples/netstack/incremental-highlevel/main.rkt
View File

@ -1,4 +1,4 @@
#lang syndicate #lang syndicate/actor
(require syndicate/protocol/advertise) (require syndicate/protocol/advertise)
@ -19,7 +19,7 @@
(struct present (who) #:prefab) (struct present (who) #:prefab)
(define (spawn-session them us) (define (spawn-session them us)
(spawn (define (send-to-remote fmt . vs) (actor (define (send-to-remote fmt . vs)
(send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))) (send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
(define (say who fmt . vs) (define (say who fmt . vs)
@ -27,65 +27,57 @@
(send-to-remote "~a ~a\n" who (apply format fmt vs)))) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
(define user (gensym 'user)) (define user (gensym 'user))
(on-start (send-to-remote "Welcome, ~a.\n" user)) (send-to-remote "Welcome, ~a.\n" user)
(stop-when (retracted (inbound (advertise (tcp-channel them us _))))) (until (retracted (inbound (advertise (tcp-channel them us _))))
(assert (present user))
(on (asserted (present $who)) (say who "arrived."))
(on (retracted (present $who)) (say who "departed."))
(assert (present user)) (on (message (says $who $what)) (say who "says: ~a" what))
(on (asserted (present $who)) (say who "arrived."))
(on (retracted (present $who)) (say who "departed."))
(on (message (says $who $what)) (say who "says: ~a" what)) (assert (outbound (advertise (tcp-channel us them _))))
(on (message (inbound (tcp-channel them us $bs)))
(send! (says user (string-trim (bytes->string/utf-8 bs))))))))
(assert (outbound (advertise (tcp-channel us them _)))) (dataspace (define us (tcp-listener 5999))
(on (message (inbound (tcp-channel them us $bs))) (forever (assert (outbound (advertise (observe (tcp-channel _ us _)))))
(send! (says user (string-trim (bytes->string/utf-8 bs))))))) (on (asserted (inbound (advertise (tcp-channel $them us _))))
(spawn-session them us)))))
(define us (tcp-listener 5999))
(dataspace #:name 'chat-dataspace
(spawn #:name 'chat-server
(assert (outbound (advertise (observe (tcp-channel _ us _)))))
(on (asserted (inbound (advertise (tcp-channel $them us _))))
(spawn-session them us)))))
(let ((dst (udp-listener 6667))) (let ((dst (udp-listener 6667)))
(spawn #:name 'udp-echo-program (actor (react
(on (message (udp-packet $src dst $body)) (on (message (udp-packet $src dst $body))
(log-info "Got packet from ~v: ~v" src body) (log-info "Got packet from ~v: ~v" src body)
(send! (udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body))))))) (send! (udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body))))))))
(let () (let ()
(dataspace #:name 'webserver-dataspace (dataspace
(spawn #:name 'webserver-counter (actor (react (field [counter 0])
(field [counter 0]) (on (message 'bump)
(on (message 'bump) (send! `(counter ,(counter)))
(send! `(counter ,(counter))) (counter (+ (counter) 1)))))
(counter (+ (counter) 1))))
(define us (tcp-listener 80)) (forever (define us (tcp-listener 80))
(spawn (assert (outbound (advertise (observe (tcp-channel _ us _))))) (assert (outbound (advertise (observe (tcp-channel _ us _)))))
(during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _))) (during/actor (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
#:name (list 'webserver-session them) (log-info "Got connection from ~v" them)
(log-info "Got connection from ~v" them) (field [done? #f])
(assert (outbound (advertise (tcp-channel us them _)))) (stop-when (rising-edge (done?)))
(on (message (inbound (tcp-channel them us _)))) ;; ignore input (assert (outbound (advertise (tcp-channel us them _))))
(on (message (inbound (tcp-channel them us _)))) ;; ignore input
(on-start (send! 'bump)) (on-start (send! 'bump))
(on (message `(counter ,$counter)) (on (message `(counter ,$counter))
(define response (define response
(string->bytes/utf-8 (string->bytes/utf-8
(format (string-append (format (string-append
"HTTP/1.0 200 OK\r\n" "HTTP/1.0 200 OK\r\n\r\n"
"Content-Type: text/html\r\n" "<h1>Hello world from syndicate-netstack!</h1>\n"
"\r\n" "<p>This is running on syndicate's own\n"
"<h1>Hello world from syndicate-netstack!</h1>\n" "<a href='https://github.com/tonyg/syndicate/'>\n"
"<p>This is running on syndicate's own\n" "TCP/IP stack</a>.</p>\n"
"<a href='https://github.com/tonyg/syndicate/'>\n" "<p>There have been ~a requests prior to this one.</p>\n")
"TCP/IP stack</a>.</p>\n" counter)))
"<p>There have been ~a requests prior to this one.</p>\n") (send! (outbound (tcp-channel us them response)))
counter))) (done? #t))))))
(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)))))))

67
examples/netstack/incremental-highlevel/pingresp.rkt
View File

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

29
examples/netstack/incremental-highlevel/port-allocator.rkt
View File

@ -1,4 +1,4 @@
#lang syndicate #lang syndicate/actor
;; UDP/TCP port allocator ;; UDP/TCP port allocator
(provide spawn-port-allocator (provide spawn-port-allocator
@ -13,21 +13,22 @@
(struct port-allocation-reply (reqid port) #:prefab) (struct port-allocation-reply (reqid port) #:prefab)
(define (spawn-port-allocator allocator-type query-used-ports) (define (spawn-port-allocator allocator-type query-used-ports)
(spawn #:name (list 'port-allocator allocator-type) (actor #:name (list 'port-allocator allocator-type)
(define local-ips (query-local-ip-addresses)) (react
(define used-ports (query-used-ports)) (define local-ips (query-local-ip-addresses))
(define used-ports (query-used-ports))
(begin/dataflow (begin/dataflow
(log-info "port-allocator ~v used ports: ~v" allocator-type (used-ports))) (log-info "port-allocator ~v used ports: ~v" allocator-type (used-ports)))
(on (message (port-allocation-request $reqid allocator-type)) (on (message (port-allocation-request $reqid allocator-type))
(define currently-used-ports (used-ports)) (define currently-used-ports (used-ports))
(let randomly-allocate-until-unused () (let randomly-allocate-until-unused ()
(define p (+ 1024 (random 64512))) (define p (+ 1024 (random 64512)))
(if (set-member? currently-used-ports p) (if (set-member? currently-used-ports p)
(randomly-allocate-until-unused) (randomly-allocate-until-unused)
(begin (used-ports (set-add currently-used-ports p)) (begin (used-ports (set-add currently-used-ports p))
(send! (port-allocation-reply reqid p)))))))) (send! (port-allocation-reply reqid p)))))))))
(define (allocate-port! type) (define (allocate-port! type)
(define reqid (gensym 'allocate-port!)) (define reqid (gensym 'allocate-port!))

1043
examples/netstack/incremental-highlevel/tcp.rkt
View File

File diff suppressed because it is too large Load Diff

135
examples/netstack/incremental-highlevel/udp.rkt
View File

@ -1,4 +1,4 @@
#lang syndicate #lang syndicate/actor
(provide (struct-out udp-remote-address) (provide (struct-out udp-remote-address)
(struct-out udp-handle) (struct-out udp-handle)
@ -50,46 +50,46 @@
(define (spawn-udp-driver) (define (spawn-udp-driver)
(spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p))) (spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p)))
(spawn-kernel-udp-driver) (spawn-kernel-udp-driver)
(spawn #:name 'udp-driver (actor #:name 'udp-driver
(on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _))) (react (on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _)))
(spawn-udp-relay (udp-listener-port h) h)) (spawn-udp-relay (udp-listener-port h) h))
(on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _))) (on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _)))
(spawn #:name (list 'udp-transient h) (actor #:name (list 'udp-transient h)
(on-start (spawn-udp-relay (allocate-port! 'udp) h)))))) (spawn-udp-relay (allocate-port! 'udp) h))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Relaying ;; Relaying
(define (spawn-udp-relay local-port local-user-addr) (define (spawn-udp-relay local-port local-user-addr)
(spawn #:name (list 'udp-relay local-port local-user-addr) (actor #:name (list 'udp-relay local-port local-user-addr)
(on-start (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr)) (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr)
(define any-remote (udp-remote-address ? ?)) (define any-remote (udp-remote-address ? ?))
(stop-when (retracted (observe (udp-packet any-remote local-user-addr _)))) (react (stop-when (retracted (observe (udp-packet any-remote local-user-addr _))))
(assert (advertise (udp-packet any-remote local-user-addr _))) (assert (advertise (udp-packet any-remote local-user-addr _)))
(assert (udp-port-allocation local-port local-user-addr)) (assert (udp-port-allocation local-port local-user-addr))
(during (host-route $ip _ _) (during (host-route $ip _ _)
(assert (advertise (udp-datagram ip local-port _ _ _))) (assert (advertise (udp-datagram ip local-port _ _ _)))
(on (message (udp-datagram $source-ip $source-port ip local-port $bs)) (on (message (udp-datagram $source-ip $source-port ip local-port $bs))
(send! (send!
(udp-packet (udp-remote-address (ip-address->hostname source-ip) (udp-packet (udp-remote-address (ip-address->hostname source-ip)
source-port) source-port)
local-user-addr local-user-addr
bs)))) bs))))
(define local-ips (query-local-ip-addresses)) (define local-ips (query-local-ip-addresses))
(on (message (udp-packet local-user-addr ($ remote-addr any-remote) $bs)) (on (message (udp-packet local-user-addr ($ remote-addr any-remote) $bs))
;; Choose arbitrary local IP address for outbound packet! ;; Choose arbitrary local IP address for outbound packet!
;; TODO: what can be done? Must I examine the routing table? ;; TODO: what can be done? Must I examine the routing table?
(match-define (udp-remote-address remote-host remote-port) remote-addr) (match-define (udp-remote-address remote-host remote-port) remote-addr)
(define remote-ip (ip-string->ip-address remote-host)) (define remote-ip (ip-string->ip-address remote-host))
(send! (udp-datagram (set-first (local-ips)) (send! (udp-datagram (set-first (local-ips))
local-port local-port
remote-ip remote-ip
remote-port remote-port
bs))))) bs))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Codec & kernel-level driver ;; Codec & kernel-level driver
@ -97,45 +97,46 @@
(define PROTOCOL-UDP 17) (define PROTOCOL-UDP 17)
(define (spawn-kernel-udp-driver) (define (spawn-kernel-udp-driver)
(spawn #:name 'kernel-udp-driver (actor #:name 'kernel-udp-driver
(assert (advertise (ip-packet #f _ _ PROTOCOL-UDP _ _))) (forever
(assert (advertise (ip-packet #f _ _ PROTOCOL-UDP _ _)))
(define local-ips (query-local-ip-addresses)) (define local-ips (query-local-ip-addresses))
(on (message (ip-packet $source-if $src-ip $dst-ip PROTOCOL-UDP _ $body)) (on (message (ip-packet $source-if $src-ip $dst-ip PROTOCOL-UDP _ $body))
(when (and source-if (set-member? (local-ips) dst-ip)) (when (and source-if (set-member? (local-ips) dst-ip))
(bit-string-case body (bit-string-case body
([ (src-port :: integer bytes 2) ([ (src-port :: integer bytes 2)
(dst-port :: integer bytes 2) (dst-port :: integer bytes 2)
(length :: integer bytes 2) (length :: integer bytes 2)
(checksum :: integer bytes 2) ;; TODO: check checksum (checksum :: integer bytes 2) ;; TODO: check checksum
(data :: binary) ] (data :: binary) ]
(bit-string-case data (bit-string-case data
([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes ([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes
(:: binary) ] (:: binary) ]
(send! (udp-datagram src-ip src-port dst-ip dst-port (send! (udp-datagram src-ip src-port dst-ip dst-port
(bit-string->bytes payload)))) (bit-string->bytes payload))))
(else #f))) (else #f)))
(else #f)))) (else #f))))
(on (message (udp-datagram $src-ip $src-port $dst-ip $dst-port $bs)) (on (message (udp-datagram $src-ip $src-port $dst-ip $dst-port $bs))
(when (set-member? (local-ips) src-ip) (when (set-member? (local-ips) src-ip)
(let* ((payload (bit-string (src-port :: integer bytes 2) (let* ((payload (bit-string (src-port :: integer bytes 2)
(dst-port :: integer bytes 2) (dst-port :: integer bytes 2)
((+ 8 (bit-string-byte-count bs)) ((+ 8 (bit-string-byte-count bs))
:: integer bytes 2) :: integer bytes 2)
(0 :: integer bytes 2) ;; checksum location (0 :: integer bytes 2) ;; checksum location
(bs :: binary))) (bs :: binary)))
(pseudo-header (bit-string (src-ip :: binary bytes 4) (pseudo-header (bit-string (src-ip :: binary bytes 4)
(dst-ip :: binary bytes 4) (dst-ip :: binary bytes 4)
0 0
PROTOCOL-UDP PROTOCOL-UDP
((bit-string-byte-count payload) ((bit-string-byte-count payload)
:: integer bytes 2))) :: integer bytes 2)))
(checksummed-payload (ip-checksum #:pseudo-header pseudo-header (checksummed-payload (ip-checksum #:pseudo-header pseudo-header
6 payload))) 6 payload)))
(send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #"" (send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #""
checksummed-payload))))))) checksummed-payload))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

16
examples/netstack/monolithic-lowlevel/README.md Normal file
View File

@ -0,0 +1,16 @@
# TCP/IP Stack
## Linux Firewall Configuration
Imagine a setup where the machine you are running this code has IP
192.168.1.10. This code claims 192.168.1.222 for itself. Now, pinging
192.168.1.222 from some other machine, say 192.168.1.99, will cause
the local kernel to receive the pings and then *forward them on to
192.168.1.222*, which because of the gratuitous ARP announcement, it
knows to be on its own Ethernet MAC address. This causes the ping
requests to repeat endlessly, each time with one lower TTL.
One approach to solving the problem is to prevent the kernel from
forwarding packets addressed to 192.168.1.222. To do this,
sudo iptables -I FORWARD -d 192.168.1.222 -j DROP

18
examples/netstack/monolithic-lowlevel/TODO.md Normal file
View File

@ -0,0 +1,18 @@
Ideas on TCP unit testing:
<https://www.snellman.net/blog/archive/2015-07-09-unit-testing-a-tcp-stack/>
Check behaviour around TCP zero-window probing. Is the correct
behaviour already a consequence of the way `send-outbound` works?
Do something smarter with TCP timers and RTT estimation than the
nothing that's already being done.
TCP options negotiation.
- SACK
- Window scaling
Bugs:
- RST kills a connection even if its sequence number is bogus. Check
to make sure it's in the window. (See
http://static.googleusercontent.com/media/research.google.com/en//pubs/archive/41848.pdf
and RFC 5961)

2
examples/netstack/monolithic-lowlevel/arp.rkt
View File

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

19
examples/netstack/monolithic-lowlevel/demo-config.rkt
View File

@ -4,23 +4,22 @@
(require racket/match) (require racket/match)
(require syndicate/monolithic) (require syndicate/monolithic)
(require (only-in mzlib/os gethostname)) (require (only-in mzlib/os gethostname))
(require (only-in racket/string string-split))
(require "configuration.rkt") (require "configuration.rkt")
(provide spawn-demo-config) (provide spawn-demo-config)
(define (spawn-demo-config) (define (spawn-demo-config)
(actor (lambda (e s) #f) (spawn (lambda (e s) #f)
(void) (void)
(match (gethostname) (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" ["stockholm.ccs.neu.edu"
(scn/union (assertion (host-route (bytes 129 10 115 94) 24 "eth0")) (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")))] (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))]
[other ;; assume a private network [else
(define interface (error 'spawn-demo-config "No setup for hostname ~a" (gethostname))])))
(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)))])))

2
examples/netstack/monolithic-lowlevel/ethernet.rkt
View File

@ -47,7 +47,7 @@
(log-info "Opened interface ~a, yielding handle ~v" interface-name h) (log-info "Opened interface ~a, yielding handle ~v" interface-name h)
(define control-ch (make-async-channel)) (define control-ch (make-async-channel))
(thread (lambda () (interface-packet-read-loop interface h control-ch))) (thread (lambda () (interface-packet-read-loop interface h control-ch)))
(actor (lambda (e h) (spawn (lambda (e h)
(match e (match e
[(scn g) [(scn g)
(if (trie-empty? g) (if (trie-empty? g)

6
examples/netstack/monolithic-lowlevel/ip.rkt
View File

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

12
examples/netstack/monolithic-lowlevel/main.rkt
View File

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

14
examples/netstack/monolithic-lowlevel/on-claim.rkt
View File

@ -10,14 +10,14 @@
;; -> Action ;; -> Action
;; Spawns a process that observes the given projections. Any time the ;; Spawns a process that observes the given projections. Any time the
;; environment's interests change in a relevant way, calls ;; environment's interests change in a relevant way, calls
;; check-and-maybe-actor-fn with the aggregate interests and the ;; check-and-maybe-spawn-fn with the aggregate interests and the
;; projection results. If check-and-maybe-actor-fn returns #f, ;; projection results. If check-and-maybe-spawn-fn returns #f,
;; continues to wait; otherwise, takes the action(s) returned, and ;; continues to wait; otherwise, takes the action(s) returned, and
;; quits. ;; quits.
(define (on-claim #:timeout-msec [timeout-msec #f] (define (on-claim #:timeout-msec [timeout-msec #f]
#:on-timeout [timeout-handler (lambda () '())] #:on-timeout [timeout-handler (lambda () '())]
#:name [name #f] #:name [name #f]
check-and-maybe-actor-fn check-and-maybe-spawn-fn
base-interests base-interests
. projections) . projections)
(define timer-id (gensym 'on-claim)) (define timer-id (gensym 'on-claim))
@ -27,18 +27,18 @@
(define projection-results (define projection-results
(map (lambda (p) (trie-project/set #:take (projection-arity p) new-aggregate p)) (map (lambda (p) (trie-project/set #:take (projection-arity p) new-aggregate p))
projections)) projections))
(define maybe-actor (apply check-and-maybe-actor-fn (define maybe-spawn (apply check-and-maybe-spawn-fn
new-aggregate new-aggregate
projection-results)) projection-results))
(if maybe-actor (if maybe-spawn
(quit maybe-actor) (quit maybe-spawn)
#f)] #f)]
[(message (timer-expired (== timer-id) _)) [(message (timer-expired (== timer-id) _))
(quit (timeout-handler))] (quit (timeout-handler))]
[_ #f])) [_ #f]))
(list (list
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative))) (when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
(actor #:name name (spawn #:name name
on-claim-handler on-claim-handler
(void) (void)
(scn/union base-interests (scn/union base-interests

2
examples/netstack/monolithic-lowlevel/port-allocator.rkt
View File

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

8
examples/netstack/monolithic-lowlevel/tcp.rkt
View File

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

4
examples/netstack/monolithic-lowlevel/udp.rkt
View File

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

76
examples/operational-transformation/syndicate-multiserver.rkt
View File

@ -1,4 +1,4 @@
#lang syndicate #lang syndicate/actor
(require racket/file) (require racket/file)
(require racket/serialize) (require racket/serialize)
@ -6,7 +6,6 @@
(require operational-transformation) (require operational-transformation)
(require operational-transformation/text/simple-document) (require operational-transformation/text/simple-document)
(require syndicate/protocol/advertise)
(require/activate syndicate/drivers/tcp) (require/activate syndicate/drivers/tcp)
(require/activate syndicate/drivers/line-reader) (require/activate syndicate/drivers/line-reader)
@ -18,47 +17,47 @@
(define cmdline-port (make-parameter 5889)) (define cmdline-port (make-parameter 5889))
(define cmdline-filenames (make-parameter '())) (define cmdline-filenames (make-parameter '()))
(spawn* (for [(filename (cmdline-filenames))] (actor (for [(filename (cmdline-filenames))]
(run-one-server filename))) (run-one-server filename)))
(define (run-one-server filename) (define (run-one-server filename)
(spawn (field [state (make-server (simple-document (actor (react (field [state (make-server (simple-document
(if (file-exists? filename) (if (file-exists? filename)
(begin (log-info "loading ~v" filename) (begin (log-info "loading ~v" filename)
(file->string filename)) (file->string filename))
(begin (log-info "will create ~v" filename) (begin (log-info "will create ~v" filename)
""))))]) ""))))])
(assert (snapshot-for filename (extract-snapshot (state)))) (assert (snapshot-for filename (extract-snapshot (state))))
(define/query-set client-seen-revs (client-seen-up-to filename $rev) rev) (define/query-set client-seen-revs (client-seen-up-to filename $rev) rev)
(field [oldest-needed-rev #f]) (field [oldest-needed-rev #f])
(begin/dataflow (begin/dataflow
(define min-rev (define min-rev
(or (for/fold [(min-rev #f)] [(rev (client-seen-revs))] (or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
(min (or min-rev rev) rev)) (min (or min-rev rev) rev))
(server-state-revision (state)))) (server-state-revision (state))))
(when (not (equal? (oldest-needed-rev) min-rev)) (when (not (equal? (oldest-needed-rev) min-rev))
(oldest-needed-rev min-rev) (oldest-needed-rev min-rev)
(state (forget-operation-history (state) min-rev)))) (state (forget-operation-history (state) min-rev))))
(begin/dataflow (begin/dataflow
(display-to-file (simple-document-text (server-state-document (state))) (display-to-file (simple-document-text (server-state-document (state)))
filename filename
#:exists 'replace)) #:exists 'replace))
(on (message (proposed-op filename $p)) (on (message (proposed-op filename $p))
(state (incorporate-operation-from-client (state) p)) (state (incorporate-operation-from-client (state) p))
(define sp (extract-operation (state))) (define sp (extract-operation (state)))
(when sp (send! (accepted-op filename sp)))))) (when sp (send! (accepted-op filename sp)))))))
(spawn (define s (tcp-listener (cmdline-port))) (actor (define s (tcp-listener (cmdline-port)))
(on-start (log-info "listening on port ~v" (cmdline-port))) (log-info "listening on port ~v" (cmdline-port))
(assert (advertise (observe (tcp-channel _ s _)))) (forever (assert (advertise (observe (tcp-channel _ s _))))
(during/spawn (advertise (tcp-channel $c s _)) (during/actor (advertise (tcp-channel $c s _))
(assert (advertise (tcp-channel s c _))) (assert (advertise (tcp-channel s c _)))
(on-start (log-info "~a: connected" c)) (on-start (log-info "~a: connected" c))
(on-stop (log-info "~a: disconnected" c)) (on-stop (log-info "~a: disconnected" c))
(connection-react c s))) (connection-react c s))))
(define (connection-react c s) (define (connection-react c s)
(define (output v) (define (output v)
@ -69,14 +68,13 @@
(send! (tcp-channel s c (get-output-bytes p)))) (send! (tcp-channel s c (get-output-bytes p))))
(field [seen-up-to 0]) (field [seen-up-to 0])
(field [selected-filename #f])
(assert #:when (selected-filename) (client-seen-up-to (selected-filename) (seen-up-to))) (assert #:when (selected-filename) (client-seen-up-to (selected-filename) (seen-up-to)))
(define/query-set available-filenames (observe (proposed-op $f _)) f) (define/query-set available-filenames (observe (proposed-op $f _)) f)
(begin/dataflow (begin/dataflow
(output (set->list (available-filenames)))) (output (set->list (available-filenames))))
(field [selected-filename #f])
(begin/dataflow (begin/dataflow
(when (selected-filename) (when (selected-filename)
(log-info "~a: attached to file ~a" c (selected-filename)) (log-info "~a: attached to file ~a" c (selected-filename))

69
examples/operational-transformation/syndicate-server.rkt
View File

@ -1,11 +1,10 @@
#lang syndicate #lang syndicate/actor
(require racket/file) (require racket/file)
(require racket/serialize) (require racket/serialize)
(require operational-transformation) (require operational-transformation)
(require operational-transformation/text/simple-document) (require operational-transformation/text/simple-document)
(require syndicate/protocol/advertise)
(require/activate syndicate/drivers/tcp) (require/activate syndicate/drivers/tcp)
(require/activate syndicate/drivers/line-reader) (require/activate syndicate/drivers/line-reader)
@ -16,43 +15,43 @@
(define cmdline-port (make-parameter 5888)) (define cmdline-port (make-parameter 5888))
(define cmdline-filename (make-parameter "info.rkt")) (define cmdline-filename (make-parameter "info.rkt"))
(spawn (field [state (make-server (simple-document (actor (react (field [state (make-server (simple-document
(if (file-exists? (cmdline-filename)) (if (file-exists? (cmdline-filename))
(begin (log-info "loading ~v" (cmdline-filename)) (begin (log-info "loading ~v" (cmdline-filename))
(file->string (cmdline-filename))) (file->string (cmdline-filename)))
(begin (log-info "will create ~v" (cmdline-filename)) (begin (log-info "will create ~v" (cmdline-filename))
""))))]) ""))))])
(assert (extract-snapshot (state))) (assert (extract-snapshot (state)))
(define/query-set client-seen-revs (client-seen-up-to $rev) rev) (define/query-set client-seen-revs (client-seen-up-to $rev) rev)
(field [oldest-needed-rev #f]) (field [oldest-needed-rev #f])
(begin/dataflow (begin/dataflow
(define min-rev (define min-rev
(or (for/fold [(min-rev #f)] [(rev (client-seen-revs))] (or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
(min (or min-rev rev) rev)) (min (or min-rev rev) rev))
(server-state-revision (state)))) (server-state-revision (state))))
(when (not (equal? (oldest-needed-rev) min-rev)) (when (not (equal? (oldest-needed-rev) min-rev))
(oldest-needed-rev min-rev) (oldest-needed-rev min-rev)
(state (forget-operation-history (state) min-rev)))) (state (forget-operation-history (state) min-rev))))
(begin/dataflow (begin/dataflow
(display-to-file (simple-document-text (server-state-document (state))) (display-to-file (simple-document-text (server-state-document (state)))
(cmdline-filename) (cmdline-filename)
#:exists 'replace)) #:exists 'replace))
(on (message (proposed-op $p)) (on (message (proposed-op $p))
(state (incorporate-operation-from-client (state) p)) (state (incorporate-operation-from-client (state) p))
(define sp (extract-operation (state))) (define sp (extract-operation (state)))
(when sp (send! (accepted-op sp))))) (when sp (send! (accepted-op sp))))))
(spawn (define s (tcp-listener (cmdline-port))) (actor (define s (tcp-listener (cmdline-port)))
(on-start (log-info "listening on port ~v" (cmdline-port))) (log-info "listening on port ~v" (cmdline-port))
(assert (advertise (observe (tcp-channel _ s _)))) (forever (assert (advertise (observe (tcp-channel _ s _))))
(during/spawn (advertise (tcp-channel $c s _)) (during/actor (advertise (tcp-channel $c s _))
(assert (advertise (tcp-channel s c _))) (assert (advertise (tcp-channel s c _)))
(on-start (log-info "~a: connected" c)) (on-start (log-info "~a: connected" c))
(on-stop (log-info "~a: disconnected" c)) (on-stop (log-info "~a: disconnected" c))
(connection-react c s (cmdline-filename)))) (connection-react c s (cmdline-filename)))))
(define (connection-react c s filename) (define (connection-react c s filename)
(define (output v) (define (output v)

586
examples/platformer/hll-main.rkt
View File

@ -1,4 +1,4 @@
#lang syndicate #lang syndicate/actor
(require 2htdp/image) (require 2htdp/image)
(require 2htdp/planetcute) (require 2htdp/planetcute)
@ -302,51 +302,53 @@
;; SceneManager ;; SceneManager
(define (spawn-scene-manager) (define (spawn-scene-manager)
(spawn #:name 'scene-manager (actor #:name 'scene-manager
(define backdrop (rectangle 1 1 "solid" "white")) (define backdrop (rectangle 1 1 "solid" "white"))
(define/query-value size (vector 0 0) (inbound (window $x $y)) (vector x y)) (react
(define/query-set osds ($ o (on-screen-display _ _ _)) o) (define/query-value size (vector 0 0) (inbound (window $x $y)) (vector x y))
(define/query-value offset (vector 0 0) (scroll-offset $v) v) (define/query-set osds ($ o (on-screen-display _ _ _)) o)
(define/query-value offset (vector 0 0) (scroll-offset $v) v)
(field [fullscreen? #f]) (field [fullscreen? #f])
(assert #:when (fullscreen?) (outbound 'fullscreen)) (assert #:when (fullscreen?) (outbound 'fullscreen))
(on (message (inbound (key-event #\f #t _))) (on (message (inbound (key-event #\f #t _)))
(fullscreen? (not (fullscreen?)))) (fullscreen? (not (fullscreen?))))
(define (compute-backdrop) (define (compute-backdrop)
(match-define (vector width height) (size)) (match-define (vector width height) (size))
(match-define (vector ofs-x ofs-y) (offset)) (match-define (vector ofs-x ofs-y) (offset))
(define osd-blocks (define osd-blocks
(for/list [(osd (in-set (osds)))] (for/list [(osd (in-set (osds)))]
(match-define (on-screen-display raw-x raw-y (seal i)) osd) (match-define (on-screen-display raw-x raw-y (seal i)) osd)
(define x (if (negative? raw-x) (+ width raw-x) raw-x)) (define x (if (negative? raw-x) (+ width raw-x) raw-x))
(define y (if (negative? raw-y) (+ height raw-y) raw-y)) (define y (if (negative? raw-y) (+ height raw-y) raw-y))
`(push-matrix (translate ,x ,y) `(push-matrix (translate ,x ,y)
(scale ,(image-width i) ,(image-height i)) (scale ,(image-width i) ,(image-height i))
(texture ,i)))) (texture ,i))))
(scene (seal `((push-matrix (scene (seal `((push-matrix
(scale ,width ,height) (scale ,width ,height)
(texture ,backdrop)) (texture ,backdrop))
(translate ,(- ofs-x) ,(- ofs-y)))) (translate ,(- ofs-x) ,(- ofs-y))))
(seal `((translate ,ofs-x ,ofs-y) (seal `((translate ,ofs-x ,ofs-y)
,@osd-blocks)))) ,@osd-blocks))))
(assert (outbound (compute-backdrop))))) (assert (outbound (compute-backdrop))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ScoreKeeper ;; ScoreKeeper
(define (spawn-score-keeper) (define (spawn-score-keeper)
(spawn #:name 'score-keeper (actor #:name 'score-keeper
(field [score 0]) (react
(assert (current-score (score))) (field [score 0])
(assert (outbound (assert (current-score (score)))
(on-screen-display -150 10 (assert (outbound
(seal (text (format "Score: ~a" (score)) 24 "white"))))) (on-screen-display -150 10
(on (message (add-to-score $delta)) (seal (text (format "Score: ~a" (score)) 24 "white")))))
(score (+ (score) delta)) (on (message (add-to-score $delta))
(log-info "Score increased by ~a to ~a" delta (score)) (score (+ (score) delta))
(play-sound-sequence 270304)))) (log-info "Score increased by ~a to ~a" delta (score))
(play-sound-sequence 270304)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PhysicsEngine ;; PhysicsEngine
@ -356,177 +358,178 @@
(define gravity 0.004) (define gravity 0.004)
(define (spawn-physics-engine) (define (spawn-physics-engine)
(spawn #:name 'physics-engine (actor #:name 'physics-engine
(field [configs (hash)] (react
[previous-positions (hash)] (field [configs (hash)]
[previous-velocities (hash)] [previous-positions (hash)]
[positions (hash)] [previous-velocities (hash)]
[velocities (hash)]) [positions (hash)]
[velocities (hash)])
(during (game-piece-configuration $id $initial-position $size $attrs) (during (game-piece-configuration $id $initial-position $size $attrs)
(on-start (configs (on-start (configs
(hash-set (configs) id (hash-set (configs) id
(game-piece-configuration id initial-position size attrs)))) (game-piece-configuration id initial-position size attrs))))
(on-stop (configs (hash-remove (configs) id)) (on-stop (configs (hash-remove (configs) id))
(positions (hash-remove (positions) id)) (positions (hash-remove (positions) id))
(velocities (hash-remove (velocities) id))) (velocities (hash-remove (velocities) id)))
(assert (position id (hash-ref (positions) id initial-position) size))) (assert (position id (hash-ref (positions) id initial-position) size)))
(define/query-hash impulses (impulse $id $vec) id vec) (define/query-hash impulses (impulse $id $vec) id vec)
(define (piece-cfg id) (hash-ref (configs) id)) (define (piece-cfg id) (hash-ref (configs) id))
(define (piece-pos which id) (define (piece-pos which id)
(hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id))))) (hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id)))))
(define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0)))) (define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0))))
(define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0)))) (define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0))))
(define (update-piece! g new-pos new-vel) (define (update-piece! g new-pos new-vel)
(positions (hash-set (positions) (game-piece-configuration-id g) new-pos)) (positions (hash-set (positions) (game-piece-configuration-id g) new-pos))
(velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel))) (velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel)))
(define (find-support p size which-pos) (define (find-support p size which-pos)
(match-define (vector p-left p-top) p) (match-define (vector p-left p-top) p)
(match-define (vector p-w p-h) size) (match-define (vector p-w p-h) size)
(define p-right (+ p-left p-w)) (define p-right (+ p-left p-w))
(define p-bottom (+ p-top p-h)) (define p-bottom (+ p-top p-h))
(for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)] (for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
(match-define (vector left top) (piece-pos which-pos id)) (match-define (vector left top) (piece-pos which-pos id))
(and (< (abs (- top p-bottom)) 0.5) (and (< (abs (- top p-bottom)) 0.5)
(<= left p-right) (<= left p-right)
(match (game-piece-configuration-size g) (match (game-piece-configuration-size g)
[(vector w h) [(vector w h)
(<= p-left (+ left w))]) (<= p-left (+ left w))])
g))) g)))
(define (segment-intersection-time p0 r q0 q1) (define (segment-intersection-time p0 r q0 q1)
;; See http://stackoverflow.com/a/565282/169231 ;; See http://stackoverflow.com/a/565282/169231
;; Enhanced to consider the direction of impact with the segment, ;; Enhanced to consider the direction of impact with the segment,
;; too: only returns an intersection when the vector of motion is ;; too: only returns an intersection when the vector of motion is
;; at an obtuse angle to the normal of the segment. ;; at an obtuse angle to the normal of the segment.
(define s (v- q1 q0)) (define s (v- q1 q0))
(define rxs (vcross2 r s)) (define rxs (vcross2 r s))
(cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear) (cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear)
[else [else
(define q-p (v- q0 p0)) (define q-p (v- q0 p0))
(define q-pxs (vcross2 q-p s)) (define q-pxs (vcross2 q-p s))
(define t (/ q-pxs rxs)) (define t (/ q-pxs rxs))
(and (<= 0 t 1) (and (<= 0 t 1)
(let* ((q-pxr (vcross2 q-p r)) (let* ((q-pxr (vcross2 q-p r))
(u (/ q-pxr rxs))) (u (/ q-pxr rxs)))
(and (< 0 u 1) (and (< 0 u 1)
(let* ((q-norm (let* ((q-norm
(vnormalize (vector (vector-ref s 1) (- (vector-ref s 0)))))) (vnormalize (vector (vector-ref s 1) (- (vector-ref s 0))))))
(and (not (positive? (vdot r q-norm))) (and (not (positive? (vdot r q-norm)))
(- t 0.001))))))])) (- t 0.001))))))]))
(define (three-corners top-left size) (define (three-corners top-left size)
(match-define (vector w h) size) (match-define (vector w h) size)
(values (v+ top-left (vector w 0)) (values (v+ top-left (vector w 0))
(v+ top-left size) (v+ top-left size)
(v+ top-left (vector 0 h)))) (v+ top-left (vector 0 h))))
(define (clip-movement-by top-left moved-top-left size solid-top-left solid-size) (define (clip-movement-by top-left moved-top-left size solid-top-left solid-size)
(define-values (solid-top-right solid-bottom-right solid-bottom-left) (define-values (solid-top-right solid-bottom-right solid-bottom-left)
(three-corners solid-top-left solid-size)) (three-corners solid-top-left solid-size))
(define-values (top-right bottom-right bottom-left) (define-values (top-right bottom-right bottom-left)
(three-corners top-left size)) (three-corners top-left size))
(define r (v- moved-top-left top-left)) (define r (v- moved-top-left top-left))
(define t (define t
(apply min (apply min
(for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))] (for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))]
(min (or (segment-intersection-time p r solid-top-left solid-top-right) 1) (min (or (segment-intersection-time p r solid-top-left solid-top-right) 1)
;; TODO: some means of specifying *which edges* should appear solid. ;; TODO: some means of specifying *which edges* should appear solid.
#;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1) #;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1)
#;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1) #;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1)
#;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1))))) #;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1)))))
(v+ top-left (v* r t))) (v+ top-left (v* r t)))
(define (clip-movement-by-solids p0 p1 size) (define (clip-movement-by-solids p0 p1 size)
(for/fold [(p1 p1)] (for/fold [(p1 p1)]
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)] [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
(clip-movement-by p0 p1 size (clip-movement-by p0 p1 size
(piece-pos previous-positions id) (piece-pos previous-positions id)
(game-piece-configuration-size g)))) (game-piece-configuration-size g))))
(define (touched-during-movement? TL moved-TL size touchable-TL touchable-size) (define (touched-during-movement? TL moved-TL size touchable-TL touchable-size)
(define r (v- moved-TL TL)) (define r (v- moved-TL TL))
(if (positive? (vmag^2 r)) ;; r is nonzero, in other words (if (positive? (vmag^2 r)) ;; r is nonzero, in other words
(let () (let ()
(define-values (touchable-TR touchable-BR touchable-BL) (define-values (touchable-TR touchable-BR touchable-BL)
(three-corners touchable-TL touchable-size)) (three-corners touchable-TL touchable-size))
(define-values (TR BR BL) (define-values (TR BR BL)
(three-corners TL size)) (three-corners TL size))
(for/or [(p (in-list (list TL TR BR BL)))] (for/or [(p (in-list (list TL TR BR BL)))]
(or (or
(and (segment-intersection-time p r touchable-TR touchable-BR) 'right) (and (segment-intersection-time p r touchable-TR touchable-BR) 'right)
(and (segment-intersection-time p r touchable-BR touchable-BL) 'bottom) (and (segment-intersection-time p r touchable-BR touchable-BL) 'bottom)
(and (segment-intersection-time p r touchable-BL touchable-TL) 'left) (and (segment-intersection-time p r touchable-BL touchable-TL) 'left)
(and (segment-intersection-time p r touchable-TL touchable-TR) 'top)))) (and (segment-intersection-time p r touchable-TL touchable-TR) 'top))))
(let () (let ()
(match-define (vector left top) TL) (match-define (vector left top) TL)
(match-define (vector touchable-left touchable-top) touchable-TL) (match-define (vector touchable-left touchable-top) touchable-TL)
(match-define (vector width height) size) (match-define (vector width height) size)
(match-define (vector touchable-width touchable-height) touchable-size) (match-define (vector touchable-width touchable-height) touchable-size)
(and (<= left (+ touchable-left touchable-width)) (and (<= left (+ touchable-left touchable-width))
(<= top (+ touchable-top touchable-height)) (<= top (+ touchable-top touchable-height))
(<= touchable-left (+ left width)) (<= touchable-left (+ left width))
(<= touchable-top (+ top height)) (<= touchable-top (+ top height))
'mid)))) 'mid))))
(define (touchables-touched-during-movement p0 p1 size) (define (touchables-touched-during-movement p0 p1 size)
(for/fold [(ts '())] (for/fold [(ts '())]
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'touchable)] [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'touchable)]
(define side (touched-during-movement? p0 p1 size (define side (touched-during-movement? p0 p1 size
(piece-pos previous-positions id) (piece-pos previous-positions id)
(game-piece-configuration-size g))) (game-piece-configuration-size g)))
(if side (cons (cons side g) ts) ts))) (if side (cons (cons side g) ts) ts)))
(define (update-game-piece! elapsed-ms id) (define (update-game-piece! elapsed-ms id)
(define g (piece-cfg id)) (define g (piece-cfg id))
(define size (game-piece-configuration-size g)) (define size (game-piece-configuration-size g))
(define pos0 (piece-pos previous-positions id)) (define pos0 (piece-pos previous-positions id))
(define support (find-support pos0 size previous-positions)) (define support (find-support pos0 size previous-positions))
(define vel0 (piece-vel previous-velocities id)) (define vel0 (piece-vel previous-velocities id))
(define imp0 (piece-imp id)) (define imp0 (piece-imp id))
(define vel1 (cond (define vel1 (cond
[(and support (not (negative? (vector-ref vel0 1)))) [(and support (not (negative? (vector-ref vel0 1))))
(piece-vel previous-velocities (game-piece-configuration-id support))] (piece-vel previous-velocities (game-piece-configuration-id support))]
[(game-piece-has-attribute? g 'massive) [(game-piece-has-attribute? g 'massive)
(v+ vel0 (vector 0 (* gravity elapsed-ms)))] (v+ vel0 (vector 0 (* gravity elapsed-ms)))]
[else [else
vel0])) vel0]))
(define pos1 (v+ pos0 (v* (v+ vel1 imp0) (* impulse-multiplier elapsed-ms)))) (define pos1 (v+ pos0 (v* (v+ vel1 imp0) (* impulse-multiplier elapsed-ms))))
(define final-pos (clip-movement-by-solids pos0 pos1 size)) (define final-pos (clip-movement-by-solids pos0 pos1 size))
;; TODO: figure out how to cancel just the component of velocity blocked by the obstacle(s) ;; TODO: figure out how to cancel just the component of velocity blocked by the obstacle(s)
;; - which will avoid the "sticking to the wall" artifact ;; - which will avoid the "sticking to the wall" artifact
(define final-vel (if (v= pos1 final-pos) vel1 (vector 0 0))) ;; stop at collision (define final-vel (if (v= pos1 final-pos) vel1 (vector 0 0))) ;; stop at collision
(define touchables (touchables-touched-during-movement pos0 final-pos size)) (define touchables (touchables-touched-during-movement pos0 final-pos size))
(retract! (touching id ? ?)) (retract! (touching id ? ?))
(for [(t touchables)] (for [(t touchables)]
(match-define (cons side tg) t) (match-define (cons side tg) t)
(assert! (touching id (game-piece-configuration-id tg) side))) (assert! (touching id (game-piece-configuration-id tg) side)))
(update-piece! g final-pos final-vel)) (update-piece! g final-pos final-vel))
(on (message (jump-request $id)) (on (message (jump-request $id))
(define g (piece-cfg id)) (define g (piece-cfg id))
(define pos (piece-pos positions id)) (define pos (piece-pos positions id))
(when (find-support pos (game-piece-configuration-size g) positions) (when (find-support pos (game-piece-configuration-size g) positions)
(play-sound-sequence 270318) (play-sound-sequence 270318)
(update-piece! g pos jump-vel))) (update-piece! g pos jump-vel)))
(on (message (inbound* game-level (frame-event $counter _ $elapsed-ms _))) (on (message (inbound* game-level (frame-event $counter _ $elapsed-ms _)))
(when (zero? (modulo counter 10)) (when (zero? (modulo counter 10))
(log-info "Instantaneous frame rate at frame ~a: ~a Hz" (log-info "Instantaneous frame rate at frame ~a: ~a Hz"
counter counter
(/ 1000.0 elapsed-ms))) (/ 1000.0 elapsed-ms)))
(previous-positions (positions)) (previous-positions (positions))
(previous-velocities (velocities)) (previous-velocities (velocities))
(for [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'mobile)] (for [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'mobile)]
(update-game-piece! elapsed-ms id))))) (update-game-piece! elapsed-ms id))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Player ;; Player
@ -535,48 +538,50 @@
(define planetcute-scale 1/2) (define planetcute-scale 1/2)
(define (spawn-player-avatar initial-focus-x initial-focus-y) (define (spawn-player-avatar initial-focus-x initial-focus-y)
(spawn #:name 'player-avatar (actor #:name 'player-avatar
(define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16)) (react
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y)) (define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16))
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
(assert (game-piece-configuration player-id (assert (game-piece-configuration player-id
initial-top-left initial-top-left
(icon-hitbox-size i) (icon-hitbox-size i)
(set 'player 'mobile 'massive))) (set 'player 'mobile 'massive)))
(define/query-value pos initial-top-left (position player-id $hitbox-top-left _) (define/query-value pos initial-top-left (position player-id $hitbox-top-left _)
hitbox-top-left) hitbox-top-left)
(assert (outbound* game-level (icon-sprite i 0 (pos)))) (assert (outbound* game-level (icon-sprite i 0 (pos))))
(field [hit-points 1]) (field [hit-points 1])
(assert (health player-id (hit-points))) (assert (health player-id (hit-points)))
(stop-when-true (<= (hit-points) 0)) (stop-when (rising-edge (<= (hit-points) 0)))
(on (message (damage player-id $amount)) (on (message (damage player-id $amount))
(hit-points (- (hit-points) amount))) (hit-points (- (hit-points) amount)))
(on (asserted (inbound* 2 (key-pressed #\space))) (send! (jump-request player-id))) (on (asserted (inbound* 2 (key-pressed #\space))) (send! (jump-request player-id)))
(on (asserted (inbound* 2 (key-pressed #\.))) (send! (jump-request player-id))) (on (asserted (inbound* 2 (key-pressed #\.))) (send! (jump-request player-id)))
(define/query-set keys-down (inbound* 2 (key-pressed $k)) k) (define/query-set keys-down (inbound* 2 (key-pressed $k)) k)
(define (any-key-down? . ks) (for/or [(k ks)] (set-member? (keys-down) k))) (define (any-key-down? . ks) (for/or [(k ks)] (set-member? (keys-down) k)))
(assert (impulse player-id (vector (+ (if (any-key-down? 'left 'prior) -1 0) (assert (impulse player-id (vector (+ (if (any-key-down? 'left 'prior) -1 0)
(if (any-key-down? 'right 'next) 1 0)) (if (any-key-down? 'right 'next) 1 0))
0))))) 0))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Ground Block ;; Ground Block
(define (spawn-ground-block top-left size #:color [color "purple"]) (define (spawn-ground-block top-left size #:color [color "purple"])
(spawn #:name (list 'ground-block top-left size color) (actor #:name (list 'ground-block top-left size color)
(match-define (vector x y) top-left) (match-define (vector x y) top-left)
(match-define (vector w h) size) (match-define (vector w h) size)
(define block-id (gensym 'ground-block)) (define block-id (gensym 'ground-block))
(define block-pict (rectangle w h "solid" color)) (define block-pict (rectangle w h "solid" color))
(assert (outbound* game-level (simple-sprite 0 x y w h block-pict))) (react
(assert (game-piece-configuration block-id (assert (outbound* game-level (simple-sprite 0 x y w h block-pict)))
(assert (game-piece-configuration block-id
top-left top-left
size size
(set 'solid))))) (set 'solid))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Goal piece ;; Goal piece
@ -589,14 +594,15 @@
(define i (icon key planetcute-scale 1/3 2/5 4/5)) (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)) (define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
(spawn #:name (list 'goal-piece initial-focus-x initial-focus-y) (actor #:name (list 'goal-piece initial-focus-x initial-focus-y)
(on (asserted (touching player-id goal-id _)) (react
(send! (outbound (level-completed)))) (on (asserted (touching player-id goal-id _))
(assert (game-piece-configuration goal-id (send! (outbound (level-completed))))
initial-top-left (assert (game-piece-configuration goal-id
(icon-hitbox-size i) initial-top-left
(set 'touchable))) (icon-hitbox-size i)
(assert (outbound* game-level (icon-sprite i -1 initial-top-left))))) (set 'touchable)))
(assert (outbound* game-level (icon-sprite i -1 initial-top-left))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Enemy ;; Enemy
@ -604,42 +610,43 @@
(define (spawn-enemy initial-x initial-y range-lo range-hi (define (spawn-enemy initial-x initial-y range-lo range-hi
#:speed [speed 0.2] #:speed [speed 0.2]
#:facing [initial-facing 'right]) #:facing [initial-facing 'right])
(spawn #:name (list 'enemy initial-x initial-y initial-facing) (actor #:name (list 'enemy initial-x initial-y initial-facing)
(define enemy-id (gensym 'enemy)) (react
(define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6)) (define enemy-id (gensym 'enemy))
(define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))])) (define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6))
(define initial-top-left (focus->top-left i initial-x initial-y)) (define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))]))
(match-define (vector width height) (icon-hitbox-size i)) (define initial-top-left (focus->top-left i initial-x initial-y))
(match-define (vector width height) (icon-hitbox-size i))
(assert (game-piece-configuration enemy-id (assert (game-piece-configuration enemy-id
initial-top-left initial-top-left
(icon-hitbox-size i) (icon-hitbox-size i)
(set 'mobile 'massive 'touchable))) (set 'mobile 'massive 'touchable)))
(define/query-value current-level-size #f (level-size $v) v) (define/query-value current-level-size #f (level-size $v) v)
(define/query-value pos initial-top-left (position enemy-id $top-left _) top-left (define/query-value pos initial-top-left (position enemy-id $top-left _) top-left
#:on-add (match-let (((vector left top) top-left)) #:on-add (match-let (((vector left top) top-left))
(facing (cond [(< left range-lo) 'right] (facing (cond [(< left range-lo) 'right]
[(> (+ left width) range-hi) 'left] [(> (+ left width) range-hi) 'left]
[else (facing)])))) [else (facing)]))))
(stop-when-true (and (current-level-size) (stop-when (rising-edge (and (current-level-size)
(> (vector-ref (pos) 1) (> (vector-ref (pos) 1)
(vector-ref (current-level-size) 1)))) (vector-ref (current-level-size) 1)))))
(field [facing initial-facing]) (field [facing initial-facing])
(assert (outbound* game-level (assert (outbound* game-level
(icon-sprite (match (facing) ['right i] ['left i-flipped]) -1 (pos)))) (icon-sprite (match (facing) ['right i] ['left i-flipped]) -1 (pos))))
(assert (impulse enemy-id (vector (* speed (match (facing) ['right 1] ['left -1])) 0))) (assert (impulse enemy-id (vector (* speed (match (facing) ['right 1] ['left -1])) 0)))
(stop-when (asserted (touching player-id enemy-id 'top)) (stop-when (asserted (touching player-id enemy-id 'top))
(play-sound-sequence 270325) (play-sound-sequence 270325)
(send! (outbound (add-to-score 1)))) (send! (outbound (add-to-score 1))))
(on (asserted (touching player-id enemy-id $side)) (on (asserted (touching player-id enemy-id $side))
(when (not (eq? side 'top)) (send! (damage player-id 1)))))) (when (not (eq? side 'top)) (send! (damage player-id 1)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DisplayControl ;; DisplayControl
@ -647,22 +654,23 @@
(define (spawn-display-controller level-size-vec) (define (spawn-display-controller level-size-vec)
(match-define (vector level-width level-height) level-size-vec) (match-define (vector level-width level-height) level-size-vec)
(spawn #:name 'display-controller (actor #:name 'display-controller
(field [offset-pos (vector 0 0)]) (react
(assert (outbound* 2 (scroll-offset (offset-pos)))) (field [offset-pos (vector 0 0)])
(assert (level-size level-size-vec)) (assert (outbound* 2 (scroll-offset (offset-pos))))
(assert (level-size level-size-vec))
(define/query-value window-size-vec #f (inbound* game-level (window $w $h)) (vector w h)) (define/query-value window-size-vec #f (inbound* game-level (window $w $h)) (vector w h))
(define (compute-offset pos viewport limit) (define (compute-offset pos viewport limit)
(min (max 0 (- pos (/ viewport 2))) (- limit viewport))) (min (max 0 (- pos (/ viewport 2))) (- limit viewport)))
(on (asserted (position player-id (vector $px $py) _)) (on (asserted (position player-id (vector $px $py) _))
(when (window-size-vec) (when (window-size-vec)
(match-define (vector ww wh) (window-size-vec)) (match-define (vector ww wh) (window-size-vec))
(when (> py level-height) (send! (damage player-id +inf.0))) (when (> py level-height) (send! (damage player-id +inf.0)))
(offset-pos (vector (compute-offset px ww level-width) (offset-pos (vector (compute-offset px ww level-width)
(compute-offset py wh level-height))))))) (compute-offset py wh level-height))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LevelTerminationMonitor ;; LevelTerminationMonitor
@ -671,24 +679,25 @@
;; kills the dataspace. ;; kills the dataspace.
(define (wait-for-level-termination) (define (wait-for-level-termination)
(spawn (react/suspend (done)
(assert (outbound (level-running))) (assert (outbound (level-running)))
(on (retracted (game-piece-configuration player-id _ _ _)) (stop-when (retracted (game-piece-configuration player-id _ _ _))
(log-info "Player died! Terminating level.") (log-info "Player died! Terminating level.")
(play-sound-sequence 270328) (play-sound-sequence 270328)
(quit-dataspace!)) (done))
(on (message (inbound (level-completed))) (stop-when (message (inbound (level-completed)))
(log-info "Level completed! Terminating level.") (log-info "Level completed! Terminating level.")
(play-sound-sequence 270330) (play-sound-sequence 270330)
(send! (outbound (add-to-score 100))) (send! (outbound (add-to-score 100)))
(quit-dataspace!)))) (done))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LevelSpawner ;; LevelSpawner
(define (spawn-standalone-assertions . patches) (define (spawn-standalone-assertions . patches)
(spawn #:name 'standalone-assertions (actor #:name 'standalone-assertions
(on-start (patch! (patch-seq* patches))))) (patch! (patch-seq* patches))
(forever)))
(define (spawn-background-image level-size scene) (define (spawn-background-image level-size scene)
(match-define (vector level-width level-height) level-size) (match-define (vector level-width level-height) level-size)
@ -778,18 +787,18 @@
message)))))) message))))))
(define (spawn-level-spawner starting-level) (define (spawn-level-spawner starting-level)
(spawn #:name 'level-spawner (actor #:name 'level-spawner
(field [current-level starting-level] (react (field [current-level starting-level]
[level-complete? #f]) [level-complete? #f])
(on (message (level-completed)) (level-complete? #t)) (on (message (level-completed)) (level-complete? #t))
(on (retracted (level-running)) (on (retracted (level-running))
(current-level (if (level-complete?) (+ (current-level) 1) (current-level))) (current-level (if (level-complete?) (+ (current-level) 1) (current-level)))
(level-complete? #f) (level-complete? #f)
(spawn-numbered-level (current-level))) (spawn-numbered-level (current-level)))
(on-start (spawn-numbered-level starting-level)))) (on-start (spawn-numbered-level starting-level)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Sounds ;; Sounds
@ -816,4 +825,5 @@
(spawn-keyboard-integrator) (spawn-keyboard-integrator)
(spawn-scene-manager) (spawn-scene-manager)
(dataspace (spawn-score-keeper) (dataspace (spawn-score-keeper)
(spawn-level-spawner 0)) (spawn-level-spawner 0)
(forever))

26
examples/platformer/lll-main.rkt
View File

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

38
examples/webchat/NOTES.md
View File

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

49
examples/webchat/htdocs/Text-x-generic.svg
View File

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

Before

Width:  |  Height:  |  Size: 2.2 KiB

1
examples/webchat/htdocs/linkify-string.min.js vendored
View File

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

1
examples/webchat/htdocs/linkify.min.js vendored
View File

File diff suppressed because one or more lines are too long

BIN
examples/webchat/htdocs/speechbubble-l.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 417 B

85
examples/webchat/htdocs/speechbubble-l.svg
View File

@ -1,85 +0,0 @@
<?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>
Side by Side

Before

Width:  |  Height:  |  Size: 2.7 KiB

BIN
examples/webchat/htdocs/speechbubble-r.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 500 B

85
examples/webchat/htdocs/speechbubble-r.svg
View File

@ -1,85 +0,0 @@
<?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>
Side by Side

Before

Width:  |  Height:  |  Size: 2.7 KiB

213
examples/webchat/htdocs/style.css
View File

@ -1,213 +0,0 @@
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;
}

22
examples/webchat/htdocs/templates/contact-entry.html
View File

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

8
examples/webchat/htdocs/templates/conversation-index-entry.html
View File

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

2
examples/webchat/htdocs/templates/grant-entry.html
View File

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

7
examples/webchat/htdocs/templates/invitee-entry.html
View File

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

24
examples/webchat/htdocs/templates/nav-account.html
View File

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

11
examples/webchat/htdocs/templates/option-question.html
View File

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

11
examples/webchat/htdocs/templates/page-contacts.html
View File

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

157
examples/webchat/htdocs/templates/page-conversations.html
View File

@ -1,157 +0,0 @@
<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}}

3
examples/webchat/htdocs/templates/page-my-requests.html
View File

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

35
examples/webchat/htdocs/templates/page-new-chat.html
View File

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

5
examples/webchat/htdocs/templates/page-permissions.html
View File

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

23
examples/webchat/htdocs/templates/page-questions.html
View File

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

2
examples/webchat/htdocs/templates/permission-entry.html
View File

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

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

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

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

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

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

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

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

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

7
examples/webchat/htdocs/templates/post-entry.html
View File

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

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

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

1
examples/webchat/htdocs/templates/post-item-image.html
View File

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

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

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

4
examples/webchat/htdocs/templates/post-item.html
View File

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

959
examples/webchat/htdocs/webchat.syndicate.js
View File

@ -1,959 +0,0 @@
(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);
}

2
examples/webchat/server/.gitignore vendored
View File

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

36
examples/webchat/server/TODO.md
View File

@ -1,36 +0,0 @@
✓ 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.

27
examples/webchat/server/account.rkt
View File

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

78
examples/webchat/server/api.rkt
View File

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

54
examples/webchat/server/config.rkt
View File

@ -1,54 +0,0 @@
#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))])))

87
examples/webchat/server/contacts.rkt
View File

@ -1,87 +0,0 @@
#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)])))))))

164
examples/webchat/server/conversation.rkt
View File

@ -1,164 +0,0 @@
#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)))])))))))

15
examples/webchat/server/duplicate.rkt
View File

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

14
examples/webchat/server/main.rkt
View File

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

277
examples/webchat/server/pages.rkt
View File

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

173
examples/webchat/server/protocol.rkt
View File

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

41
examples/webchat/server/qa.rkt
View File

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

5
examples/webchat/server/run
View File

@ -1,5 +0,0 @@
#!/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

25
examples/webchat/server/script-compiler.rkt
View File

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

54
examples/webchat/server/session-cookie.rkt
View File

@ -1,54 +0,0 @@
#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 ...])]))]))

45
examples/webchat/server/static-content.rkt
View File

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

23
examples/webchat/server/testdata.rkt
View File

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

51
examples/webchat/server/trust.rkt
View File

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

9
examples/webchat/server/util.rkt
View File

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

0
LICENSE → hs/LICENSE
View File

4
hs/src/Syndicate/Dataspace/Trie/Prefix.hs
View File

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

174
js/compiler/compiler.js
View File

@ -42,29 +42,29 @@ var forEachChild = (function () {
return forEachChild; return forEachChild;
})(); })();
function buildActor(nameExpOpt, block, withReact) { function buildActor(constructorES5, nameExpOpt, block) {
var nameExpStr; var nameExpStr;
if (nameExpOpt.numChildren === 1) { if (nameExpOpt.numChildren === 1) {
nameExpStr = ', ' + nameExpOpt.asES5; nameExpStr = ', ' + nameExpOpt.asES5;
} else { } else {
nameExpStr = ''; nameExpStr = '';
} }
return 'Syndicate.Actor.spawnActor(function() ' + return 'Syndicate.Actor.spawnActor(new '+constructorES5+', '+
(withReact ? reactWrap(block.asES5) : block.asES5) + 'function() ' + block.asES5 + nameExpStr + ');';
nameExpStr + ');';
} }
function reactWrap(blockCode) { function buildFacet(facetBlock, transitionBlock) {
return '{ Syndicate.Actor.Facet.build(function () { ' + return '(function () { ' + (facetBlock ? facetBlock.facetVarDecls : '') +
blockCode + '\nSyndicate.Actor.createFacet()' +
' }); }'; (facetBlock ? facetBlock.asES5 : '') +
(transitionBlock ? transitionBlock.asES5 : '') +
'.completeBuild(); })();';
} }
function buildOnEvent(isTerminal, eventType, subscription, projection, bindings, body) { function buildOnEvent(isTerminal, eventType, subscription, projection, bindings, body) {
return 'Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, ' + isTerminal + ', ' + return '\n.onEvent(' + isTerminal + ', ' + JSON.stringify(eventType) + ', ' +
JSON.stringify(eventType) + ', ' +
subscription + ', ' + projection + subscription + ', ' + projection +
', (function(' + bindings.join(', ') + ') ' + body + '));'; ', (function(' + bindings.join(', ') + ') ' + body + '))';
} }
function buildCaseEvent(eventPattern, body) { function buildCaseEvent(eventPattern, body) {
@ -86,11 +86,11 @@ function buildCaseEvent(eventPattern, body) {
} }
var modifiedSourceActions = { var modifiedSourceActions = {
ActorStatement_noReact: function(_spawnStar, _namedOpt, nameExpOpt, block) { ActorStatement_noConstructor: function(_actor, _namedOpt, nameExpOpt, block) {
return buildActor(nameExpOpt, block, false); return buildActor('Object()', nameExpOpt, block);
}, },
ActorStatement_withReact: function(_spawn, _namedOpt, nameExpOpt, block) { ActorStatement_withConstructor: function(_actor, ctorExp, _namedOpt, nameExpOpt, block) {
return buildActor(nameExpOpt, block, true); return buildActor(ctorExp.asES5, nameExpOpt, block);
}, },
DataspaceStatement_ground: function(_ground, _dataspace, maybeId, block) { DataspaceStatement_ground: function(_ground, _dataspace, maybeId, block) {
@ -105,8 +105,14 @@ var modifiedSourceActions = {
return 'Syndicate.Dataspace.spawn(new Dataspace(function () ' + block.asES5 + '));'; return 'Syndicate.Dataspace.spawn(new Dataspace(function () ' + block.asES5 + '));';
}, },
ActorFacetStatement: function(_react, block) { ActorFacetStatement_state: function(_state, facetBlock, _until, transitionBlock) {
return '(function () ' + reactWrap(block.asES5) + ').call(this);'; return buildFacet(facetBlock, transitionBlock);
},
ActorFacetStatement_until: function(_react, _until, transitionBlock) {
return buildFacet(null, transitionBlock);
},
ActorFacetStatement_forever: function(_forever, facetBlock) {
return buildFacet(facetBlock, null);
}, },
AssertionTypeDeclarationStatement: function(_assertion, AssertionTypeDeclarationStatement: function(_assertion,
@ -127,39 +133,28 @@ var modifiedSourceActions = {
label + ', ' + JSON.stringify(formals) + ');'; label + ', ' + JSON.stringify(formals) + ');';
}, },
FieldDeclarationStatement: function(_field, memberExpr, _eq, maybeInitExpr, sc) {
return 'Syndicate.Actor.declareField(' + memberExpr.memberObjectExpr.asES5 + ', ' +
memberExpr.memberPropExpr.asES5 + ', ' +
(maybeInitExpr.numChildren === 1 ? maybeInitExpr.asES5 : 'undefined') +
')' +
sc.interval.contents;
},
MemberExpression_fieldRefExp: function (_field, memberExpr) {
return 'Syndicate.Actor.referenceField(' + memberExpr.memberObjectExpr.asES5 + ', ' +
memberExpr.memberPropExpr.asES5 + ')';
},
UnaryExpression_fieldDelExp: function (_delete, _field, memberExpr) {
return 'Syndicate.Actor.deleteField(' + memberExpr.memberObjectExpr.asES5 + ', ' +
memberExpr.memberPropExpr.asES5 + ')';
},
SendMessageStatement: function(_colons, expr, sc) { SendMessageStatement: function(_colons, expr, sc) {
return 'Syndicate.Dataspace.send(' + expr.asES5 + ')' + sc.interval.contents; return 'Syndicate.Dataspace.send(' + expr.asES5 + ')' + sc.interval.contents;
}, },
ActorEndpointStatement_start: function (_on, _start, block) { FacetBlock: function(_leftParen, _varStmts, init, situations, done, _rightParen) {
return 'Syndicate.Actor.Facet.current.addInitBlock((function() ' + block.asES5 + '));'; return (init ? init.asES5 : '') + situations.asES5.join('') + (done ? done.asES5 : '');
}, },
ActorEndpointStatement_stop: function (_on, _stop, block) { FacetStateTransitionBlock: function(_leftParen, transitions, _rightParen) {
return 'Syndicate.Actor.Facet.current.addDoneBlock((function() ' + block.asES5 + '));'; return transitions.asES5.join('');
}, },
ActorEndpointStatement_assert: function(_assert, expr, whenClause, _sc) {
return 'Syndicate.Actor.Facet.current.addAssertion(' + FacetInitBlock: function(_init, block) {
buildSubscription([expr], 'assert', 'pattern', whenClause, null) + ');'; return '\n.addInitBlock((function() ' + block.asES5 + '))';
}, },
ActorEndpointStatement_event: function(_on, eventPattern, block) { FacetDoneBlock: function(_done, block) {
return '\n.addDoneBlock((function() ' + block.asES5 + '))';
},
FacetSituation_assert: function(_assert, expr, whenClause, _sc) {
return '\n.addAssertion(' + buildSubscription([expr], 'assert', 'pattern', whenClause, null) + ')';
},
FacetSituation_event: function(_on, eventPattern, block) {
return buildOnEvent(false, return buildOnEvent(false,
eventPattern.eventType, eventPattern.eventType,
eventPattern.subscription, eventPattern.subscription,
@ -167,84 +162,49 @@ var modifiedSourceActions = {
eventPattern.bindings, eventPattern.bindings,
block.asES5); block.asES5);
}, },
ActorEndpointStatement_onEvent: function (_on, _event, id, block) { FacetSituation_onEvent: function (_on, _event, id, block) {
return 'Syndicate.Actor.Facet.current.addOnEventHandler((function(' + id.asES5 + ') ' + return '\n.addOnEventHandler((function(' + id.asES5 + ') ' + block.asES5 + '))';
block.asES5 + '));';
}, },
ActorEndpointStatement_stopOnWithCont: function(_stop, _on, eventPattern, block) { FacetSituation_during: function(_during, pattern, facetBlock) {
return buildCaseEvent(eventPattern, block.asES5);
},
ActorEndpointStatement_stopOnNoCont: function(_stop, _on, eventPattern, _sc) {
return buildCaseEvent(eventPattern, '{}');
},
ActorEndpointStatement_dataflow: function (_dataflow, block) {
return 'Syndicate.Actor.Facet.current.addDataflow((function () ' + block.asES5 + '));';
},
ActorEndpointStatement_during: function(_during, pattern, block) {
var cachedAssertionVar = gensym('cachedAssertion'); var cachedAssertionVar = gensym('cachedAssertion');
return buildOnEvent(false, return buildOnEvent(false,
'asserted', 'asserted',
pattern.subscription, pattern.subscription,
pattern.projection, pattern.projection,
pattern.bindings, pattern.bindings,
'{\n' + '{ ' + facetBlock.facetVarDecls +
'var '+cachedAssertionVar+' = '+pattern.instantiatedAssertion+';\n'+ '\nvar '+cachedAssertionVar+' = '+pattern.instantiatedAssertion+';'+
reactWrap(block.asES5 + '\n' + '\nSyndicate.Actor.createFacet()' +
buildOnEvent(true, facetBlock.asES5 +
'retracted', buildOnEvent(true,
pattern.instantiatedSubscription(cachedAssertionVar), 'retracted',
pattern.instantiatedProjection(cachedAssertionVar), pattern.instantiatedSubscription(cachedAssertionVar),
[], pattern.instantiatedProjection(cachedAssertionVar),
'{}')) + '}'); [],
}, '{}') +
ActorEndpointStatement_duringSpawn: function(_during, pattern, _spawn, _named, nameExpOpt, block) '.completeBuild(); }');
{
var cachedAssertionVar = gensym('cachedAssertion');
var actorBlock = {
asES5: reactWrap(block.asES5 + '\n' +
buildOnEvent(true,
'retracted',
pattern.instantiatedSubscription(cachedAssertionVar),
pattern.instantiatedProjection(cachedAssertionVar),
[],
'{}'))
};
return buildOnEvent(false,
'asserted',
pattern.subscription,
pattern.projection,
pattern.bindings,
'{ var '+cachedAssertionVar+' = '+pattern.instantiatedAssertion+';\n'+
buildActor(nameExpOpt, actorBlock, true) + ' }');
}, },
AssertWhenClause: function(_when, _lparen, expr, _rparen) { AssertWhenClause: function(_when, _lparen, expr, _rparen) {
return expr.asES5; return expr.asES5;
},
FacetStateTransition_withContinuation: function(_case, eventPattern, block) {
return buildCaseEvent(eventPattern, block.asES5);
},
FacetStateTransition_noContinuation: function(_case, eventPattern, _sc) {
return buildCaseEvent(eventPattern, '{}');
} }
}; };
semantics.extendAttribute('modifiedSource', modifiedSourceActions); semantics.extendAttribute('modifiedSource', modifiedSourceActions);
semantics.addAttribute('memberObjectExpr', { semantics.addAttribute('facetVarDecls', {
MemberExpression_propRefExp: function(objExpr, _dot, id) { FacetBlock: function (_leftParen, varDecls, _init, _situations, _done, _rightParen) {
return objExpr; return varDecls.asES5.join(' ');
},
MemberExpression_arrayRefExp: function(objExpr, _lbrack, propExpr, _rbrack) {
return objExpr;
} }
}); });
semantics.addAttribute('memberPropExpr', {
MemberExpression_propRefExp: function(objExpr, _dot, id) {
return { asES5: JSON.stringify(id.interval.contents) };
},
MemberExpression_arrayRefExp: function(objExpr, _lbrack, propExpr, _rbrack) {
return propExpr;
}
});
///////////////////////////////////////////////////////////////////////////
semantics.addAttribute('asSyndicateStructureArguments', { semantics.addAttribute('asSyndicateStructureArguments', {
FormalParameterList: function(formals) { FormalParameterList: function(formals) {
return formals.asIteration().asSyndicateStructureArguments; return formals.asIteration().asSyndicateStructureArguments;
@ -309,7 +269,7 @@ semantics.addAttribute('instantiatedAssertion', {
var fragments = []; var fragments = [];
fragments.push('(function() { var _ = Syndicate.__; return '); fragments.push('(function() { var _ = Syndicate.__; return ');
children.forEach(function (c) { fragments.push(c.buildSubscription('instantiated')); }); children.forEach(function (c) { fragments.push(c.buildSubscription('instantiated')); });
fragments.push('; }).call(this)'); fragments.push('; })()');
return fragments.join(''); return fragments.join('');
} }
}); });
@ -385,12 +345,6 @@ semantics.addOperation('buildSubscription(mode)', {
} }
}, },
MemberExpression_fieldRefExp: function (_field, memberExpr) {
return 'Syndicate.Actor.referenceField(' +
memberExpr.memberObjectExpr.buildSubscription(this.args.mode) + ', ' +
memberExpr.memberPropExpr.buildSubscription(this.args.mode) + ')';
},
identifier: function(_name) { identifier: function(_name) {
var i = this.interval.contents; var i = this.interval.contents;
if (i[0] === '$' && i.length > 1) { if (i[0] === '$' && i.length > 1) {
@ -412,7 +366,7 @@ semantics.addOperation('buildSubscription(mode)', {
return ES5.translateNonterminalCode(children, return ES5.translateNonterminalCode(children,
function(n) { function(n) {
return n.buildSubscription(self.args.mode); return n.buildSubscription(self.args.mode);
}) || this.interval.contents; });
} }
}); });

59
js/compiler/demo-bad-this.js
View File

@ -1,59 +0,0 @@
// 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); }
}
}
}

45
js/compiler/demo-bankaccount.js
View File

@ -6,31 +6,38 @@ assertion type account(balance);
message type deposit(amount); message type deposit(amount);
ground dataspace { ground dataspace {
spawn { actor {
field this.balance = 0; this.balance = 0;
assert account(this.balance);
dataflow { react {
console.log("Balance inside account is", this.balance); assert account(this.balance);
} on message deposit($amount) {
on message deposit($amount) { this.balance += amount;
this.balance += amount; }
} }
} }
spawn { actor {
on asserted account($balance) { react {
console.log("Balance is now", balance); on asserted account($balance) {
console.log("Balance is now", balance);
}
} }
} }
spawn { actor {
on start { react {
console.log("Waiting for account."); do {
} console.log("Waiting for account.");
stop on asserted Syndicate.observe(deposit(_)) { }
console.log("Account became ready."); finally {
:: deposit(+100); console.log("Account became ready.");
:: deposit(-30); }
} until {
case asserted Syndicate.observe(deposit(_)) {
:: deposit(+100);
:: deposit(-30);
}
} }
} }
} }

25
js/compiler/demo-during-criterion-snapshotting.js
View File

@ -19,20 +19,21 @@ var Dataspace = Syndicate.Dataspace;
assertion type foo(x, y); assertion type foo(x, y);
ground dataspace { ground dataspace {
spawn { actor {
field this.x = 123; var x = 123;
react {
assert foo(x, 999);
assert foo(this.x, 999); during foo(x, $v) {
do {
during foo(this.x, $v) { console.log('x=', x, 'v=', v);
on start { if (x === 123) {
console.log('x=', this.x, 'v=', v); x = 124;
if (this.x === 123) { }
this.x = 124; }
finally {
console.log('finally for x=', x, 'v=', v);
} }
}
on stop {
console.log('finally for x=', this.x, 'v=', v);
} }
} }
} }

82
js/compiler/demo-filesystem.js
View File

@ -1,17 +1,5 @@
// bin/syndicatec compiler/demo-filesystem.js | node // bin/syndicatec compiler/demo-filesystem.js | node
// Good output:
//
// At least one reader exists for: hello.txt
// hello.txt has content undefined
// hello.txt has content "a"
// hello.txt has content undefined
// hello.txt has content "c"
// hello.txt has content "quit demo"
// The hello.txt file contained 'quit demo', so we will quit
// second observer sees that hello.txt content is "final contents"
// No remaining readers exist for: hello.txt
var Syndicate = require('./src/main.js'); var Syndicate = require('./src/main.js');
assertion type file(name, content) = "file"; assertion type file(name, content) = "file";
@ -22,49 +10,55 @@ ground dataspace {
/////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////
// The file system actor // The file system actor
spawn { actor {
this.files = {}; this.files = {};
during Syndicate.observe(file($name, _)) { react {
on start { during Syndicate.observe(file($name, _)) {
console.log("At least one reader exists for:", name); do {
console.log("At least one reader exists for:", name);
}
assert file(name, this.files[name]);
finally {
console.log("No remaining readers exist for:", name);
}
} }
assert file(name, field this.files[name]); on message saveFile($name, $newcontent) {
on stop { this.files[name] = newcontent;
console.log("No remaining readers exist for:", name); }
on message deleteFile($name) {
delete this.files[name];
} }
}
on message saveFile($name, $newcontent) {
field this.files[name] = newcontent;
}
on message deleteFile($name) {
delete field this.files[name];
} }
} }
/////////////////////////////////////////////////////////////////////////// ///////////////////////////////////////////////////////////////////////////
// A simple demo client of the file system // A simple demo client of the file system
spawn { actor {
on asserted file("hello.txt", $content) { react {
console.log("hello.txt has content", JSON.stringify(content)); on asserted file("hello.txt", $content) {
console.log("hello.txt has content", JSON.stringify(content));
}
} until {
case asserted file("hello.txt", "quit demo") {
console.log("The hello.txt file contained 'quit demo', so we will quit");
}
} }
stop on asserted file("hello.txt", "quit demo") { react until {
console.log("The hello.txt file contained 'quit demo', so we will quit"); case asserted Syndicate.observe(saveFile(_, _)) {
} :: saveFile("hello.txt", "a");
} :: deleteFile("hello.txt");
:: saveFile("hello.txt", "c");
spawn { :: saveFile("hello.txt", "quit demo");
stop on asserted Syndicate.observe(saveFile(_, _)) { :: saveFile("hello.txt", "final contents");
:: saveFile("hello.txt", "a"); actor {
:: deleteFile("hello.txt"); react until {
:: saveFile("hello.txt", "c"); case asserted file("hello.txt", $content) {
:: saveFile("hello.txt", "quit demo"); console.log("second observer sees that hello.txt content is",
:: saveFile("hello.txt", "final contents"); JSON.stringify(content));
spawn { }
stop on asserted file("hello.txt", $content) { }
console.log("second observer sees that hello.txt content is",
JSON.stringify(content));
} }
} }
} }

119
js/compiler/demo-nested-during.js
View File

@ -1,119 +0,0 @@
// Illustrates a bug where dataflow damage was being repaired even for
// subjects pertaining to previously-terminated facets.
//
// Should eventually be turned into some kind of test case.
//---------------------------------------------------------------------------
// Bad output:
//
// OUTER++ first
// ++ first
// VIEW++ VIEW first
// VIEW-- VIEW first
// VIEW++ EDIT first
// VIEW-- EDIT first
// VIEW++ VIEW first
// -- first
// OUTER-- first
// OUTER++ second
// ++ second
// VIEW-- VIEW first
// VIEW++ VIEW second
// Kicking off second edit cycle
// VIEW-- VIEW second
// VIEW++ EDIT second
// VIEW++ EDIT first
// VIEW-- EDIT second
// VIEW-- EDIT first
// VIEW++ VIEW second
// VIEW++ VIEW first
//
// Notice the appearance of "first" even after the "second edit cycle" has been kicked off!
//---------------------------------------------------------------------------
// Good output:
//
// OUTER++ first
// ++ first
// VIEW++ VIEW first
// VIEW-- VIEW first
// VIEW++ EDIT first
// VIEW-- EDIT first
// VIEW++ VIEW first
// -- first
// OUTER-- first
// OUTER++ second
// ++ second
// VIEW-- VIEW first
// VIEW++ VIEW second
// Kicking off second edit cycle
// VIEW-- VIEW second
// VIEW++ EDIT second
// VIEW-- EDIT second
// VIEW++ VIEW second
//---------------------------------------------------------------------------
var Syndicate = require('./src/main.js');
assertion type todo(title);
assertion type show();
assertion type view(str);
ground dataspace {
spawn {
field this.title = "first";
assert todo(this.title);
on message 3 {
this.title = "second";
}
}
spawn {
assert show();
}
spawn {
field this.editing = false;
during todo($title) {
on start { console.log('OUTER++', title); }
during show() {
on start { console.log('++', title); }
assert view((this.editing ? 'EDIT ' : 'VIEW ') + title);
on stop { console.log('--', title); }
}
on stop { console.log('OUTER--', title); }
}
on message 1 {
this.editing = true;
:: 2;
}
on message 2 {
:: 3;
this.editing = false;
}
}
spawn {
on start { :: 0; }
stop on message 0 {
:: 1;
}
}
spawn {
field this.count = 0;
on retracted view($x) { console.log('VIEW--', x); }
on asserted view($x) {
console.log('VIEW++', x);
if (x === 'VIEW second') {
this.count++;
if (this.count === 1) {
console.log("Kicking off second edit cycle");
:: 1;
}
}
}
}
}

78
js/compiler/demo-proper-interest-tracking.js
View File

@ -14,29 +14,34 @@ assertion type ready(what);
assertion type entry(key, val); assertion type entry(key, val);
ground dataspace { ground dataspace {
spawn named 'listener' { actor named 'listener' {
assert ready('listener'); react {
on asserted entry($key, _) { assert ready('listener');
console.log('key asserted', key); on asserted entry($key, _) {
react { console.log('key asserted', key);
on asserted entry(key, $value) { console.log('binding', key, '--->', value); } react {
on retracted entry(key, $value) { console.log('binding', key, '-/->', value); } on asserted entry(key, $value) { console.log('binding', key, '--->', value); }
stop on retracted entry(key, _) { on retracted entry(key, $value) { console.log('binding', key, '-/->', value); }
console.log('key retracted', key); } until {
case retracted entry(key, _) {
console.log('key retracted', key);
}
} }
} }
} }
} }
spawn named 'other-listener' { actor named 'other-listener' {
assert ready('other-listener'); react {
during entry($key, _) { assert ready('other-listener');
on start { console.log('(other-listener) key asserted', key); } during entry($key, _) {
during entry(key, $value) { do { console.log('(other-listener) key asserted', key); }
on start { console.log('(other-listener) binding', key, '--->', value); } during entry(key, $value) {
on stop { console.log('(other-listener) binding', key, '-/->', value); } do { console.log('(other-listener) binding', key, '--->', value); }
finally { console.log('(other-listener) binding', key, '-/->', value); }
}
finally { console.log('(other-listener) key retracted', key); }
} }
on stop { console.log('(other-listener) key retracted', key); }
} }
} }
@ -44,33 +49,36 @@ ground dataspace {
console.log('pause'); console.log('pause');
react { react {
assert ready('pause'); assert ready('pause');
on asserted ready('pause') { } until {
case asserted ready('pause') {
return k(); return k();
} }
} }
} }
spawn named 'driver' { actor named 'driver' {
stop on asserted ready('listener') { react until {
react { case asserted ready('listener') {
stop on asserted ready('other-listener') { react until {
Dataspace.stateChange(Patch.assert(entry('a', 1))); case asserted ready('other-listener') {
Dataspace.stateChange(Patch.assert(entry('a', 2))); Dataspace.stateChange(Patch.assert(entry('a', 1)));
Dataspace.stateChange(Patch.assert(entry('b', 3))); Dataspace.stateChange(Patch.assert(entry('a', 2)));
Dataspace.stateChange(Patch.assert(entry('c', 33))); Dataspace.stateChange(Patch.assert(entry('b', 3)));
Dataspace.stateChange(Patch.assert(entry('a', 4))); Dataspace.stateChange(Patch.assert(entry('c', 33)));
Dataspace.stateChange(Patch.assert(entry('a', 5))); Dataspace.stateChange(Patch.assert(entry('a', 4)));
pause(function () { Dataspace.stateChange(Patch.assert(entry('a', 5)));
Dataspace.stateChange(Patch.retract(entry('a', 2)));
Dataspace.stateChange(Patch.retract(entry('c', 33)));
Dataspace.stateChange(Patch.assert(entry('a', 9)));
pause(function () { pause(function () {
Dataspace.stateChange(Patch.retract(entry('a', __))); Dataspace.stateChange(Patch.retract(entry('a', 2)));
Dataspace.stateChange(Patch.retract(entry('c', 33)));
Dataspace.stateChange(Patch.assert(entry('a', 9)));
pause(function () { pause(function () {
console.log('done'); Dataspace.stateChange(Patch.retract(entry('a', __)));
pause(function () {
console.log('done');
});
}); });
}); });
}); }
} }
} }
} }

55
js/compiler/demo-synthetic-patch-2.js
View File

@ -1,55 +0,0 @@
// 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();
}
}
}
}

Some files were not shown because too many files have changed in this diff Show More