Compare commits
1 Commits
main
...
render_dat
Author | SHA1 | Date |
---|---|---|
Tony Garnock-Jones | acf5db57f8 |
17
README.md
17
README.md
|
@ -47,19 +47,6 @@ This repository contains
|
|||
- a sketch of a Haskell implementation of the core routing structures
|
||||
of Syndicate in `hs/`
|
||||
|
||||
## Copyright and License
|
||||
## Copyright
|
||||
|
||||
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018.
|
||||
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU Lesser General Public License as published by
|
||||
the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014, 2015, 2016.
|
||||
|
|
|
@ -1,2 +0,0 @@
|
|||
scratch/
|
||||
compiled/
|
|
@ -1,7 +0,0 @@
|
|||
all:
|
||||
|
||||
run:
|
||||
raco make main.rkt && racket main.rkt
|
||||
|
||||
clean:
|
||||
rm -rf compiled
|
|
@ -1,17 +0,0 @@
|
|||
Try changing the motd and saving the file. It'll reload. The log
|
||||
messages suggest that the server is dropping extant connection - as
|
||||
expected - but it immediately comes back momentarily before going away
|
||||
properly. The session is able to reboot due to the glitching in
|
||||
assertion of the listen port *more quickly* than the latency of
|
||||
teardown of the previous connection; so the new session-listener
|
||||
responds to the assertions from the old connection before the old
|
||||
connection has a chance to die. Of course, it *does* die (since commit
|
||||
11de40c), but having that zombie reborn new session is annoying.
|
||||
|
||||
- This is thorny. You'd think that having a session wait for its
|
||||
line-reader to go would be enough, but the multiple nested
|
||||
during/spawns creating the sessions mean that no matter how long
|
||||
the old session instance sticks around, a new session will appear
|
||||
before we're ready! ... maybe there's no way *at all* to
|
||||
disambiguate old/new instances without, say, a unique
|
||||
listener-socket identifier??
|
|
@ -1,24 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "protocol.rkt")
|
||||
(require "message.rkt")
|
||||
|
||||
(require/activate syndicate/reload)
|
||||
|
||||
(spawn #:name 'channel-factory
|
||||
(stop-when-reloaded)
|
||||
(during/spawn (ircd-channel-member $Ch _)
|
||||
#:name `(ircd-channel ,Ch)
|
||||
(field [topic #f])
|
||||
(assert (ircd-channel-topic Ch (topic)))
|
||||
|
||||
(on (message (ircd-action $who (irc-message _ "MODE" (list Ch "b") _)))
|
||||
(send! (ircd-event who (irc-message server-prefix 368 (list (lookup-nick who) Ch)
|
||||
"End of Channel Ban List"))))
|
||||
|
||||
(on (message (ircd-action $who (irc-message _ "MODE" (list Ch) _)))
|
||||
(send! (ircd-event who (irc-message server-prefix 324
|
||||
(list (lookup-nick who) Ch "+") #f))))
|
||||
|
||||
(on (message (ircd-action _ (irc-message _ "TOPIC" (list Ch) $new-topic)))
|
||||
(topic new-topic))))
|
|
@ -1,14 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require/activate syndicate/reload)
|
||||
(require/activate syndicate/supervise)
|
||||
(require/activate syndicate/drivers/config)
|
||||
|
||||
(require "protocol.rkt")
|
||||
|
||||
(spawn #:name 'config
|
||||
(stop-when-reloaded)
|
||||
|
||||
(assert (ircd-motd (list "Hello, world!")))
|
||||
|
||||
(assert (ircd-listener 6667)))
|
|
@ -1,7 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require/activate syndicate/reload)
|
||||
|
||||
(spawn-reloader "config.rkt")
|
||||
(spawn-reloader "session.rkt")
|
||||
(spawn-reloader "channel.rkt")
|
|
@ -1,93 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out irc-message)
|
||||
(struct-out irc-user)
|
||||
(struct-out irc-privmsg)
|
||||
|
||||
(struct-out irc-source-servername)
|
||||
(struct-out irc-source-nick)
|
||||
|
||||
parse-irc-message
|
||||
render-irc-message
|
||||
|
||||
;; TODO make these assertions in the dataspace:
|
||||
server-name
|
||||
server-prefix)
|
||||
|
||||
(require racket/string)
|
||||
(require racket/match)
|
||||
(require racket/format)
|
||||
|
||||
;; <message> ::= [':' <prefix> <SPACE> ] <command> <params> <crlf>
|
||||
;; <prefix> ::= <servername> | <nick> [ '!' <user> ] [ '@' <host> ]
|
||||
;; <command> ::= <letter> { <letter> } | <number> <number> <number>
|
||||
;; <SPACE> ::= ' ' { ' ' }
|
||||
;; <params> ::= <SPACE> [ ':' <trailing> | <middle> <params> ]
|
||||
;;
|
||||
;; <middle> ::= <Any *non-empty* sequence of octets not including SPACE
|
||||
;; or NUL or CR or LF, the first of which may not be ':'>
|
||||
;; <trailing> ::= <Any, possibly *empty*, sequence of octets not including
|
||||
;; NUL or CR or LF>
|
||||
;;
|
||||
;; <crlf> ::= CR LF
|
||||
|
||||
;; <target> ::= <to> [ "," <target> ]
|
||||
;; <to> ::= <channel> | <user> '@' <servername> | <nick> | <mask>
|
||||
;; <channel> ::= ('#' | '&') <chstring>
|
||||
;; <servername> ::= <host>
|
||||
;; <host> ::= see RFC 952 [DNS:4] for details on allowed hostnames
|
||||
;; <nick> ::= <letter> { <letter> | <number> | <special> }
|
||||
;; <mask> ::= ('#' | '$') <chstring>
|
||||
;; <chstring> ::= <any 8bit code except SPACE, BELL, NUL, CR, LF and
|
||||
;; comma (',')>
|
||||
|
||||
;; <user> ::= <nonwhite> { <nonwhite> }
|
||||
;; <letter> ::= 'a' ... 'z' | 'A' ... 'Z'
|
||||
;; <number> ::= '0' ... '9'
|
||||
;; <special> ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'
|
||||
|
||||
;; <nonwhite> ::= <any 8bit code except SPACE (0x20), NUL (0x0), CR
|
||||
;; (0xd), and LF (0xa)>
|
||||
|
||||
(struct irc-message (prefix command params trailing) #:prefab)
|
||||
(struct irc-user (username hostname realname) #:prefab)
|
||||
(struct irc-privmsg (source target text) #:prefab)
|
||||
|
||||
(struct irc-source-servername (servername) #:prefab)
|
||||
(struct irc-source-nick (nick user) #:prefab)
|
||||
|
||||
(define (parse-irc-message line0)
|
||||
(match (string-trim #:left? #f line0 #px"[\r\n]")
|
||||
[(pregexp #px"^:([^ ]+) +(.*)$" (list _ prefix rest)) (parse-command prefix rest)]
|
||||
[line (parse-command #f line)]))
|
||||
|
||||
(define (parse-command prefix line)
|
||||
(match-define (pregexp #px"^([^ ]+)( +([^:]+)?(:(.*))?)?$" (list _ command _ params _ rest)) line)
|
||||
(irc-message prefix
|
||||
(string-upcase command)
|
||||
(string-split (or params ""))
|
||||
rest))
|
||||
|
||||
;; libpurple's irc protocol support crashes (!) (SIGSEGV) if you send
|
||||
;; a prefix on a JOIN event from the server as just "nick" rather than
|
||||
;; "nick!user@host" - specifically, it will crash if "!" doesn't
|
||||
;; appear in the prefix.
|
||||
;;
|
||||
(define (render-irc-message m)
|
||||
(match-define (irc-message prefix command params trailing) m)
|
||||
(string-append (render-prefix prefix)
|
||||
(~a command)
|
||||
(if (pair? params) (string-append " " (string-join (map ~a params))) "")
|
||||
(if trailing (string-append " :" trailing) "")))
|
||||
|
||||
(define (render-prefix p)
|
||||
(match p
|
||||
[#f
|
||||
""]
|
||||
[(irc-source-servername servername)
|
||||
(format ":~a " servername)]
|
||||
[(irc-source-nick nick (irc-user username hostname _))
|
||||
(format ":~a!~a@~a " nick username hostname)]))
|
||||
|
||||
(define server-name "syndicate-ircd")
|
||||
(define server-prefix (irc-source-servername "syndicate-ircd.example"))
|
|
@ -1,30 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(provide (struct-out ircd-listener)
|
||||
(struct-out ircd-motd)
|
||||
|
||||
(struct-out ircd-connection-info)
|
||||
(struct-out ircd-channel-member)
|
||||
(struct-out ircd-channel-topic)
|
||||
|
||||
(struct-out ircd-action)
|
||||
(struct-out ircd-event)
|
||||
|
||||
lookup-nick)
|
||||
|
||||
;; A Connection is a TcpAddress
|
||||
|
||||
(struct ircd-listener (port) #:prefab) ;; assertion
|
||||
(struct ircd-motd (lines) #:prefab) ;; assertion
|
||||
|
||||
(struct ircd-connection-info (conn nick user) #:prefab) ;;assertion
|
||||
(struct ircd-channel-member (channel conn) #:prefab) ;; assertion
|
||||
(struct ircd-channel-topic (channel topic) #:prefab) ;; assertion
|
||||
|
||||
(struct ircd-action (conn message) #:prefab) ;; message
|
||||
(struct ircd-event (conn message) #:prefab) ;; message
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (lookup-nick conn)
|
||||
(immediate-query [query-value #f (ircd-connection-info conn $N _) N]))
|
|
@ -1,177 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require racket/set)
|
||||
(require racket/string)
|
||||
|
||||
(require "protocol.rkt")
|
||||
(require "message.rkt")
|
||||
|
||||
(require/activate syndicate/reload)
|
||||
(require/activate syndicate/drivers/tcp)
|
||||
(require/activate syndicate/drivers/line-reader)
|
||||
(require syndicate/protocol/advertise)
|
||||
(require syndicate/support/hash)
|
||||
|
||||
(define (ircd-connection-facet this-conn server-handle)
|
||||
(define (send-to-remote #:newline [with-newline #t] fmt . vs)
|
||||
(define bs (string->bytes/utf-8 (apply format fmt vs)))
|
||||
(log-info "~a <- ~v" this-conn bs)
|
||||
(send! (tcp-channel server-handle this-conn (if with-newline (bytes-append bs #"\r\n") bs))))
|
||||
|
||||
(define (send-irc-message m)
|
||||
(send-to-remote "~a" (render-irc-message m)))
|
||||
|
||||
(define (send* #:source [prefix server-prefix] #:trailing [trailing #f] command . params)
|
||||
(send-irc-message (irc-message prefix command params trailing)))
|
||||
|
||||
(on-start (log-info "Connecting ~a" this-conn))
|
||||
(on-stop (log-info "Disconnecting ~a" this-conn))
|
||||
|
||||
(field [nick #f]
|
||||
[user #f])
|
||||
(define/dataflow conn-info (ircd-connection-info this-conn (nick) (user)))
|
||||
(assert (conn-info))
|
||||
|
||||
(on-start
|
||||
(react
|
||||
(stop-when (asserted (ircd-motd $motd-lines))
|
||||
(react
|
||||
(begin/dataflow
|
||||
(when (and (nick) (user))
|
||||
(send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name))
|
||||
(for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line)))
|
||||
(send* 376 (nick) #:trailing (format "End of /MOTD command"))
|
||||
(stop-current-facet)))))))
|
||||
|
||||
(field [peer-common-channels (hash)]
|
||||
[peer-names (hash)])
|
||||
|
||||
(during (ircd-channel-member $Ch this-conn)
|
||||
(field [initial-names-sent? #f]
|
||||
[initial-member-nicks (set)])
|
||||
|
||||
(on-start (send* #:source (irc-source-nick (nick) (user)) "JOIN" Ch)
|
||||
(flush!)
|
||||
(flush!)
|
||||
(define nicks (initial-member-nicks))
|
||||
(initial-names-sent? #t)
|
||||
(initial-member-nicks 'no-longer-valid)
|
||||
(send* 353 (nick) "@" Ch #:trailing (string-join (set->list nicks)))
|
||||
(send* 366 (nick) Ch #:trailing "End of /NAMES list"))
|
||||
|
||||
(during (ircd-channel-member Ch $other-conn)
|
||||
(on-start (peer-common-channels (hashset-add (peer-common-channels) other-conn Ch)))
|
||||
(on-stop (peer-common-channels (hashset-remove (peer-common-channels) other-conn Ch)))
|
||||
(field [current-other-source #f])
|
||||
(define/query-value next-other-source #f
|
||||
(ircd-connection-info other-conn $N $U)
|
||||
(irc-source-nick N U))
|
||||
(on (retracted (ircd-channel-member Ch other-conn))
|
||||
(when (current-other-source) (send* #:source (current-other-source) "PART" Ch)))
|
||||
(on-stop (when (not (hash-has-key? (peer-common-channels) other-conn))
|
||||
(peer-names (hash-remove (peer-names) other-conn))))
|
||||
(begin/dataflow
|
||||
(when (not (equal? (current-other-source) (next-other-source)))
|
||||
(if (not (next-other-source)) ;; other-conn is disconnecting
|
||||
(when (hash-ref (peer-names) other-conn #f)
|
||||
(send* #:source (current-other-source) "QUIT")
|
||||
(peer-names (hash-remove (peer-names) other-conn)))
|
||||
(begin
|
||||
(cond
|
||||
[(not (initial-names-sent?)) ;; still gathering data for 353/366 below
|
||||
(initial-member-nicks (set-add (initial-member-nicks)
|
||||
(irc-source-nick-nick (next-other-source))))]
|
||||
[(not (current-other-source)) ;; other-conn is joining
|
||||
(send* #:source (next-other-source) "JOIN" Ch)]
|
||||
[else ;; it's a nick change
|
||||
(when (not (equal? this-conn other-conn)) ;; avoid dups for our own connection
|
||||
(when (not (equal? (next-other-source) (hash-ref (peer-names) other-conn #f)))
|
||||
(send* #:source (current-other-source) "NICK"
|
||||
(irc-source-nick-nick (next-other-source)))))])
|
||||
(peer-names (hash-set (peer-names) other-conn (next-other-source)))))
|
||||
(current-other-source (next-other-source)))))
|
||||
|
||||
(on (asserted (ircd-channel-topic Ch $topic))
|
||||
(if topic
|
||||
(send* 332 (nick) Ch #:trailing topic)
|
||||
(send* 331 (nick) Ch #:trailing "No topic is set")))
|
||||
|
||||
(on (message (ircd-action this-conn (irc-message _ "WHO" (list Ch) _)))
|
||||
(flush!) ;; Wait for responses to come in. GROSS and not in
|
||||
;; general correct (e.g. in the presence of
|
||||
;; pipelining)
|
||||
(send! (ircd-event this-conn
|
||||
(irc-message server-prefix 315 (list (nick) Ch) "End of WHO list."))))
|
||||
(on (message (ircd-action $who (irc-message _ "WHO" (list Ch) _)))
|
||||
(match-define (irc-user U H R) (user))
|
||||
(send! (ircd-event who (irc-message server-prefix 352
|
||||
(list (nick) Ch U H server-name (nick) "H")
|
||||
(format "0 ~a" R)))))
|
||||
|
||||
(on (message (ircd-action $other-conn (irc-privmsg $source Ch $text)))
|
||||
(when (not (equal? other-conn this-conn))
|
||||
(send* #:source source "PRIVMSG" Ch #:trailing text))))
|
||||
|
||||
(on (message (ircd-event this-conn $m))
|
||||
(send-irc-message m))
|
||||
|
||||
(on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text)))
|
||||
(when (not (equal? other-conn this-conn))
|
||||
(send* #:source source "PRIVMSG" (nick) #:trailing text)))
|
||||
|
||||
(on (message (tcp-channel-line this-conn server-handle $bs))
|
||||
(define m (parse-irc-message (bytes->string/utf-8 bs)))
|
||||
(log-info "~a -> ~v" this-conn m)
|
||||
(send! (ircd-action this-conn m))
|
||||
(match m
|
||||
[(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs
|
||||
[(or (irc-message _ "NICK" (list N) _)
|
||||
(irc-message _ "NICK" '() N)) ;; libpurple does this (!)
|
||||
;; TODO: enforce syntactic restrictions on nick
|
||||
(if (immediate-query [query-value #f (ircd-connection-info _ N _) #t])
|
||||
(send* 433 N #:trailing "Nickname is already in use")
|
||||
(begin (when (nick) (send* #:source (irc-source-nick (nick) (user)) "NICK" N))
|
||||
(nick N)))]
|
||||
[(irc-message _ "USER" (list U _Hostname _Servername) R)
|
||||
;; TODO: enforce syntactic restrictions on parameters to USER
|
||||
(define H (tcp-address-host this-conn))
|
||||
(user (irc-user U H R))]
|
||||
[(irc-message _ "QUIT" _ _) (stop-current-facet)]
|
||||
[_
|
||||
(when (and (nick) (user))
|
||||
(match m
|
||||
[(irc-message _ "JOIN" (cons Channels _MaybeKeys) _)
|
||||
(for [(Ch (string-split Channels #px",+"))]
|
||||
(assert! (ircd-channel-member Ch this-conn)))]
|
||||
[(irc-message _ "PART" (list Channels) _)
|
||||
(for [(Ch (string-split Channels #px",+"))]
|
||||
(retract! (ircd-channel-member Ch this-conn)))]
|
||||
[(irc-message _ "WHOIS" _ _)
|
||||
(send* 318 (nick) #:trailing "End of /WHOIS list")] ;; TODO
|
||||
[(irc-message _ "PRIVMSG" (list Targets) Text)
|
||||
(for [(T (string-split Targets #px",+"))]
|
||||
(send! (ircd-action this-conn
|
||||
(irc-privmsg (irc-source-nick (nick) (user)) T Text))))]
|
||||
[_ (void)]))])))
|
||||
|
||||
(spawn #:name 'ison-responder
|
||||
(stop-when-reloaded)
|
||||
(define/query-set nicks (ircd-connection-info _ $N _) N)
|
||||
(on (message (ircd-action $conn (irc-message _ "ISON" $SomeNicks $MoreNicks)))
|
||||
(define Nicks (append SomeNicks (string-split (or MoreNicks ""))))
|
||||
(define (on? N) (set-member? (nicks) N))
|
||||
(define Present (string-join (filter on? Nicks) " "))
|
||||
(send! (ircd-event conn (irc-message server-prefix 303 '("*") Present)))))
|
||||
|
||||
(spawn #:name 'session-listener-factory
|
||||
(stop-when-reloaded)
|
||||
(during/spawn (ircd-listener $port)
|
||||
#:name (ircd-listener port)
|
||||
(on-start (log-info "Listening on port ~a." port))
|
||||
(on-stop (log-info "No longer listening on port ~a." port))
|
||||
(define server-handle (tcp-listener port))
|
||||
(assert (advertise (observe (tcp-channel _ server-handle _))))
|
||||
(during/spawn (advertise (tcp-channel $this-conn server-handle _))
|
||||
#:name `(ircd-connection ,this-conn ,server-handle)
|
||||
(assert (advertise (tcp-channel server-handle this-conn _)))
|
||||
(ircd-connection-facet this-conn server-handle))))
|
|
@ -5,8 +5,3 @@ run:
|
|||
|
||||
clean:
|
||||
find . -name compiled -type d | xargs rm -rf
|
||||
rm -f cpingresp
|
||||
|
||||
cpingresp: cpingresp.c
|
||||
$(CC) -o $@ $<
|
||||
sudo setcap cap_net_raw+p+i+e $@
|
||||
|
|
|
@ -1,18 +1,5 @@
|
|||
# TCP/IP Stack
|
||||
|
||||
There are two (closely-related) implementations here:
|
||||
|
||||
- [`monolithic-lowlevel`](monolithic-lowlevel/) is the original
|
||||
implementation, originally written for `minimart`, a language that
|
||||
followed our ESOP 2014 paper quite closely. Porting it to a
|
||||
monolithic-assertion-set Syndicate dialect helped substantially
|
||||
simplify the code.
|
||||
|
||||
- [`incremental-highlevel`](incremental-highlevel/) is a port of
|
||||
`monolithic-lowlevel` to the Syndicate high-level DSL
|
||||
("`syndicate/actor`"). Moving from the low-level Syndicate style to
|
||||
the high-level style also drastically simplified the code.
|
||||
|
||||
## Linux Firewall Configuration
|
||||
|
||||
Imagine a setup where the machine you are running this code has IP
|
|
@ -11,14 +11,8 @@ TCP options negotiation.
|
|||
- SACK
|
||||
- Window scaling
|
||||
|
||||
Check that we handle the situations in figs. 9, 10, 11, pp.33- of RFC 793.
|
||||
|
||||
Bugs:
|
||||
- RST kills a connection even if its sequence number is bogus. Check
|
||||
to make sure it's in the window. (See
|
||||
http://static.googleusercontent.com/media/research.google.com/en//pubs/archive/41848.pdf
|
||||
and RFC 5961)
|
||||
|
||||
Conform better to the rules for reset generation and processing
|
||||
from pp.36- of RFC 793. In particular, do not blindly accept RSTs
|
||||
without checking sequence numbers against windows etc.
|
|
@ -1,4 +1,4 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
;; ARP protocol, http://tools.ietf.org/html/rfc826
|
||||
;; Only does ARP-over-ethernet.
|
||||
|
||||
|
@ -29,15 +29,15 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (spawn-arp-driver)
|
||||
(spawn #:name 'arp-driver
|
||||
(during/spawn (arp-interface $interface-name)
|
||||
#:name (list 'arp-interface interface-name)
|
||||
(assert (arp-interface-up interface-name))
|
||||
(on-start (define hwaddr (lookup-ethernet-hwaddr interface-name))
|
||||
(when (not hwaddr)
|
||||
(error 'arp "Failed to look up ARP interface ~v"
|
||||
interface-name))
|
||||
(react (run-arp-interface interface-name hwaddr))))))
|
||||
(actor #:name 'arp-driver
|
||||
(react (during/actor (arp-interface $interface-name)
|
||||
#:name (list 'arp-interface interface-name)
|
||||
(assert (arp-interface-up interface-name))
|
||||
(on-start (define hwaddr (lookup-ethernet-hwaddr interface-name))
|
||||
(when (not hwaddr)
|
||||
(error 'arp "Failed to look up ARP interface ~v"
|
||||
interface-name))
|
||||
(react (run-arp-interface interface-name hwaddr)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
@ -1,219 +0,0 @@
|
|||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <stdint.h>
|
||||
#include <ctype.h>
|
||||
|
||||
#include <sys/types.h>
|
||||
#include <sys/socket.h>
|
||||
#include <sys/time.h>
|
||||
#include <sys/ioctl.h>
|
||||
|
||||
#include <fcntl.h>
|
||||
#include <err.h>
|
||||
#include <errno.h>
|
||||
#include <unistd.h>
|
||||
#include <ifaddrs.h>
|
||||
|
||||
#include <net/if.h>
|
||||
#include <net/ethernet.h>
|
||||
#include <arpa/inet.h> /* for htons */
|
||||
|
||||
#include <pthread.h>
|
||||
|
||||
#include <net/if_arp.h>
|
||||
#include <netpacket/packet.h>
|
||||
|
||||
static int lookupInterfaceInfo(int sock, char const *interfaceName, int info, struct ifreq *ifr) {
|
||||
strncpy(ifr->ifr_name, interfaceName, IFNAMSIZ);
|
||||
if (ioctl(sock, info, ifr) < 0) {
|
||||
perror("ioctl error while looking performing ioctl on interface");
|
||||
fprintf(stderr, "(ioctl number 0x%08x, interface %s)\n", info, interfaceName);
|
||||
return -1;
|
||||
} else {
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
static int bindToInterface(int sock, char const *interfaceName) {
|
||||
struct ifreq ifr;
|
||||
struct sockaddr_ll socketAddress;
|
||||
|
||||
if (lookupInterfaceInfo(sock, interfaceName, SIOCGIFINDEX, &ifr) < 0) {
|
||||
return -1;
|
||||
}
|
||||
|
||||
socketAddress.sll_family = AF_PACKET;
|
||||
socketAddress.sll_protocol = htons(ETH_P_ALL);
|
||||
socketAddress.sll_ifindex = ifr.ifr_ifindex;
|
||||
|
||||
if (bind(sock, (struct sockaddr *) &socketAddress, sizeof(socketAddress)) < 0) {
|
||||
perror("Bind error");
|
||||
return -1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int openSocket(char const *interfaceName) {
|
||||
int sock = socket(AF_PACKET, SOCK_RAW, htons(ETH_P_ALL));
|
||||
if (sock < 0) {
|
||||
perror("Socket error");
|
||||
return -1;
|
||||
}
|
||||
|
||||
if (bindToInterface(sock, interfaceName) == -1) {
|
||||
return -1;
|
||||
}
|
||||
|
||||
return sock;
|
||||
}
|
||||
|
||||
/* hwaddr should be of length ETH_ALEN */
|
||||
static int socket_hwaddr(int sock, char const *interfaceName, char *hwaddr) {
|
||||
struct ifreq ifr;
|
||||
|
||||
if (lookupInterfaceInfo(sock, interfaceName, SIOCGIFHWADDR, &ifr) < 0) {
|
||||
return -1;
|
||||
}
|
||||
|
||||
if (ifr.ifr_hwaddr.sa_family != ARPHRD_ETHER) {
|
||||
return -1;
|
||||
}
|
||||
|
||||
memcpy(hwaddr, ifr.ifr_hwaddr.sa_data, ETH_ALEN);
|
||||
return 0;
|
||||
}
|
||||
|
||||
static void dump_row(long count, int numinrow, int *chs) {
|
||||
int i;
|
||||
|
||||
printf("%08lX:", count - numinrow);
|
||||
|
||||
if (numinrow > 0) {
|
||||
for (i = 0; i < numinrow; i++) {
|
||||
if (i == 8)
|
||||
printf(" :");
|
||||
printf(" %02X", chs[i]);
|
||||
}
|
||||
for (i = numinrow; i < 16; i++) {
|
||||
if (i == 8)
|
||||
printf(" :");
|
||||
printf(" ");
|
||||
}
|
||||
printf(" ");
|
||||
for (i = 0; i < numinrow; i++) {
|
||||
if (isprint(chs[i]))
|
||||
printf("%c", chs[i]);
|
||||
else
|
||||
printf(".");
|
||||
}
|
||||
}
|
||||
printf("\n");
|
||||
}
|
||||
|
||||
static int rows_eq(int *a, int *b) {
|
||||
int i;
|
||||
|
||||
for (i=0; i<16; i++)
|
||||
if (a[i] != b[i])
|
||||
return 0;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
void dump_buffer_to_stdout(void *buf_v, int len, int hexmode) {
|
||||
unsigned char *buf = (unsigned char *) buf_v;
|
||||
long count = 0;
|
||||
int numinrow = 0;
|
||||
int chs[16];
|
||||
int oldchs[16];
|
||||
int showed_dots = 0;
|
||||
int i;
|
||||
|
||||
if (hexmode) {
|
||||
for (i = 0; i < len; i++) {
|
||||
int ch = buf[i];
|
||||
|
||||
if (numinrow == 16) {
|
||||
int i;
|
||||
|
||||
if (rows_eq(oldchs, chs)) {
|
||||
if (!showed_dots) {
|
||||
showed_dots = 1;
|
||||
printf(" .. .. .. .. .. .. .. .. : .. .. .. .. .. .. .. ..\n");
|
||||
}
|
||||
} else {
|
||||
showed_dots = 0;
|
||||
dump_row(count, numinrow, chs);
|
||||
}
|
||||
|
||||
for (i=0; i<16; i++)
|
||||
oldchs[i] = chs[i];
|
||||
|
||||
numinrow = 0;
|
||||
}
|
||||
|
||||
count++;
|
||||
chs[numinrow++] = ch;
|
||||
}
|
||||
|
||||
dump_row(count, numinrow, chs);
|
||||
|
||||
if (numinrow != 0)
|
||||
printf("%08lX:\n", count);
|
||||
} else {
|
||||
fwrite(buf, 1, len, stdout);
|
||||
printf("\n");
|
||||
fflush(NULL);
|
||||
}
|
||||
}
|
||||
|
||||
int main(int argc, char const *argv[]) {
|
||||
int handle = openSocket("eth0");
|
||||
uint8_t buf[65536];
|
||||
|
||||
while (1) {
|
||||
ssize_t len = recv(handle, &buf[0], sizeof(buf), MSG_TRUNC);
|
||||
if (len == -1) {
|
||||
perror("recv");
|
||||
break;
|
||||
}
|
||||
|
||||
uint8_t *ipbuf = buf + 14;
|
||||
|
||||
uint32_t self_ip = 0x810a735e;
|
||||
|
||||
uint32_t remote_ip = ntohl(*(int *)(&ipbuf[12]));
|
||||
uint32_t local_ip = ntohl(*(int *)(&ipbuf[16]));
|
||||
|
||||
if (local_ip == self_ip) {
|
||||
printf("Got ping from %d.%d.%d.%d\n", ipbuf[12], ipbuf[13], ipbuf[14], ipbuf[15]);
|
||||
if ((len >= 28) && (ipbuf[9] == 1) && (ipbuf[20] == 8)) {
|
||||
ipbuf[20] = 0;
|
||||
{
|
||||
short *icmp_cksum = (short *) (&ipbuf[22]);
|
||||
*icmp_cksum = htons(ntohs(*icmp_cksum) + 0x0800);
|
||||
}
|
||||
*(int *)(&ipbuf[12]) = htonl(local_ip);
|
||||
*(int *)(&ipbuf[16]) = htonl(remote_ip);
|
||||
|
||||
{
|
||||
uint8_t mac[6];
|
||||
memcpy(mac, buf, 6);
|
||||
memcpy(buf, buf+6, 6);
|
||||
memcpy(buf+6, mac, 6);
|
||||
}
|
||||
{
|
||||
ssize_t written = write(handle, buf, len);
|
||||
if (written != len) {
|
||||
perror("write");
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
|
@ -1,21 +1,21 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
;; Demonstration stack configuration for various hosts.
|
||||
|
||||
(require racket/match)
|
||||
(require (only-in mzlib/os gethostname))
|
||||
(require (only-in racket/string string-split))
|
||||
(require "configuration.rkt")
|
||||
|
||||
(spawn
|
||||
(match (gethostname)
|
||||
["stockholm.ccs.neu.edu"
|
||||
(assert (host-route (bytes 129 10 115 94) 24 "eth0"))
|
||||
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0"))]
|
||||
[other ;; assume a private network
|
||||
(define interface
|
||||
(match (car (string-split other "."))
|
||||
["skip" "en0"]
|
||||
["leap" "wlp4s0"] ;; wtf
|
||||
[_ "wlan0"]))
|
||||
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
|
||||
(assert (host-route (bytes 192 168 1 222) 24 interface))]))
|
||||
(actor
|
||||
(react
|
||||
(match (gethostname)
|
||||
["skip"
|
||||
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0"))
|
||||
(assert (host-route (bytes 192 168 1 222) 24 "en0"))]
|
||||
[(or "hop" "walk")
|
||||
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0"))
|
||||
(assert (host-route (bytes 192 168 1 222) 24 "wlan0"))]
|
||||
["stockholm.ccs.neu.edu"
|
||||
(assert (host-route (bytes 129 10 115 94) 24 "eth0"))
|
||||
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0"))]
|
||||
[other
|
||||
(error 'demo-config "No setup for hostname ~a" other)])))
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
;; Ethernet driver
|
||||
|
||||
(provide (struct-out ethernet-packet)
|
||||
|
@ -29,44 +29,44 @@
|
|||
(log-info "Device names: ~a" interface-names)
|
||||
|
||||
(define (spawn-ethernet-driver)
|
||||
(spawn #:name 'ethernet-driver
|
||||
(during/spawn
|
||||
(observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _))
|
||||
#:name (list 'ethernet-interface interface-name)
|
||||
(actor #:name 'ethernet-driver
|
||||
(react (during/actor
|
||||
(observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _))
|
||||
#:name (list 'ethernet-interface interface-name)
|
||||
|
||||
(define h (raw-interface-open interface-name))
|
||||
(when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
|
||||
(log-info "Opened interface ~a, yielding handle ~v" interface-name h)
|
||||
(define h (raw-interface-open interface-name))
|
||||
(when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name))
|
||||
(log-info "Opened interface ~a, yielding handle ~v" interface-name h)
|
||||
|
||||
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
|
||||
(assert interface)
|
||||
(define interface (ethernet-interface interface-name (raw-interface-hwaddr h)))
|
||||
(assert interface)
|
||||
|
||||
(define control-ch (make-async-channel))
|
||||
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
|
||||
(define control-ch (make-async-channel))
|
||||
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
|
||||
|
||||
(on-start (flush!) ;; ensure all subscriptions are in place
|
||||
(async-channel-put control-ch 'unblock)
|
||||
(spawn #:name (list 'ethernet-interface-quit-monitor interface-name)
|
||||
(on (retracted interface)
|
||||
(async-channel-put control-ch 'quit))))
|
||||
(on-start (flush!) ;; ensure all subscriptions are in place
|
||||
(async-channel-put control-ch 'unblock)
|
||||
(actor #:name (list 'ethernet-interface-quit-monitor interface-name)
|
||||
(react (on (retracted interface)
|
||||
(async-channel-put control-ch 'quit)))))
|
||||
|
||||
(on (message (inbound ($ p (ethernet-packet interface #t _ _ _ _))))
|
||||
;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
|
||||
;; (ethernet-interface-name (ethernet-packet-interface p))
|
||||
;; (pretty-bytes (ethernet-packet-source p))
|
||||
;; (pretty-bytes (ethernet-packet-destination p))
|
||||
;; (number->string (ethernet-packet-ethertype p) 16))
|
||||
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
|
||||
(send! p))
|
||||
(on (message (inbound ($ p (ethernet-packet interface #t _ _ _ _))))
|
||||
;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)"
|
||||
;; (ethernet-interface-name (ethernet-packet-interface p))
|
||||
;; (pretty-bytes (ethernet-packet-source p))
|
||||
;; (pretty-bytes (ethernet-packet-destination p))
|
||||
;; (number->string (ethernet-packet-ethertype p) 16))
|
||||
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
|
||||
(send! p))
|
||||
|
||||
(on (message ($ p (ethernet-packet interface #f _ _ _ _)))
|
||||
;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
|
||||
;; (ethernet-interface-name (ethernet-packet-interface p))
|
||||
;; (pretty-bytes (ethernet-packet-source p))
|
||||
;; (pretty-bytes (ethernet-packet-destination p))
|
||||
;; (number->string (ethernet-packet-ethertype p) 16))
|
||||
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
|
||||
(raw-interface-write h (encode-ethernet-packet p))))))
|
||||
(on (message ($ p (ethernet-packet interface #f _ _ _ _)))
|
||||
;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)"
|
||||
;; (ethernet-interface-name (ethernet-packet-interface p))
|
||||
;; (pretty-bytes (ethernet-packet-source p))
|
||||
;; (pretty-bytes (ethernet-packet-destination p))
|
||||
;; (number->string (ethernet-packet-ethertype p) 16))
|
||||
;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))
|
||||
(raw-interface-write h (encode-ethernet-packet p)))))))
|
||||
|
||||
(define (interface-packet-read-loop interface h control-ch)
|
||||
(define (blocked)
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
|
||||
(require/activate syndicate/drivers/timer)
|
||||
(require/activate "ethernet.rkt")
|
||||
|
@ -14,13 +14,14 @@
|
|||
(define local-handle (tcp-handle 'httpclient))
|
||||
(define remote-handle (tcp-address "81.4.107.66" 80))
|
||||
|
||||
(actor (assert (advertise (tcp-channel local-handle remote-handle _)))
|
||||
(on (asserted (advertise (tcp-channel remote-handle local-handle _)))
|
||||
(send! (tcp-channel local-handle
|
||||
remote-handle
|
||||
#"GET / HTTP/1.0\r\nHost: leastfixedpoint.com\r\n\r\n")))
|
||||
(stop-when (retracted (advertise (tcp-channel remote-handle local-handle _)))
|
||||
(printf "URL fetcher exiting.\n"))
|
||||
(on (message (tcp-channel remote-handle local-handle $bs))
|
||||
(printf "----------------------------------------\n~a\n" bs)
|
||||
(printf "----------------------------------------\n"))))
|
||||
(actor (react
|
||||
(assert (advertise (tcp-channel local-handle remote-handle _)))
|
||||
(on (asserted (advertise (tcp-channel remote-handle local-handle _)))
|
||||
(send! (tcp-channel local-handle
|
||||
remote-handle
|
||||
#"GET / HTTP/1.0\r\nHost: leastfixedpoint.com\r\n\r\n")))
|
||||
(stop-when (retracted (advertise (tcp-channel remote-handle local-handle _)))
|
||||
(printf "URL fetcher exiting.\n"))
|
||||
(on (message (tcp-channel remote-handle local-handle $bs))
|
||||
(printf "----------------------------------------\n~a\n" bs)
|
||||
(printf "----------------------------------------\n")))))
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
|
||||
(provide (struct-out ip-packet)
|
||||
ip-address->hostname
|
||||
|
@ -57,17 +57,18 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (spawn-ip-driver)
|
||||
(spawn #:name 'ip-driver
|
||||
(during/spawn (host-route $my-address $netmask $interface-name)
|
||||
(assert (route-up (host-route my-address netmask interface-name)))
|
||||
(do-host-route my-address netmask interface-name))
|
||||
(during/spawn (gateway-route $network $netmask $gateway-addr $interface-name)
|
||||
(assert (route-up
|
||||
(gateway-route $network $netmask $gateway-addr $interface-name)))
|
||||
(do-gateway-route network netmask gateway-addr interface-name))
|
||||
(during/spawn (net-route $network-addr $netmask $link)
|
||||
(assert (route-up (net-route network-addr netmask link)))
|
||||
(do-net-route network-addr netmask link))))
|
||||
(actor #:name 'ip-driver
|
||||
(react
|
||||
(during/actor (host-route $my-address $netmask $interface-name)
|
||||
(assert (route-up (host-route my-address netmask interface-name)))
|
||||
(do-host-route my-address netmask interface-name))
|
||||
(during/actor (gateway-route $network $netmask $gateway-addr $interface-name)
|
||||
(assert (route-up
|
||||
(gateway-route $network $netmask $gateway-addr $interface-name)))
|
||||
(do-gateway-route network netmask gateway-addr interface-name))
|
||||
(during/actor (net-route $network-addr $netmask $link)
|
||||
(assert (route-up (net-route network-addr netmask link)))
|
||||
(do-net-route network-addr netmask link)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Local IP route
|
||||
|
@ -176,22 +177,20 @@
|
|||
(when (and (not (equal? (ip-packet-source-interface p) interface-name))
|
||||
(ip-address-in-subnet? destination network netmask))
|
||||
(define timer-id (gensym 'ippkt))
|
||||
;; v Use `spawn` instead of `react` to avoid gratuitous packet
|
||||
;; reordering.
|
||||
(spawn (on-start (send! (set-timer timer-id 5000 'relative)))
|
||||
(react (on-start (send! (set-timer timer-id 5000 'relative)))
|
||||
(stop-when (message (timer-expired timer-id _))
|
||||
(log-warning "ARP lookup of ~a failed, packet dropped"
|
||||
(ip-address->hostname destination)))
|
||||
(log-warning "ARP lookup of ~a failed, packet dropped"
|
||||
(ip-address->hostname destination)))
|
||||
(stop-when (asserted (arp-query IPv4-ethertype
|
||||
destination
|
||||
($ interface (ethernet-interface interface-name _))
|
||||
$destination-hwaddr))
|
||||
(send! (ethernet-packet interface
|
||||
#f
|
||||
(ethernet-interface-hwaddr interface)
|
||||
destination-hwaddr
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p))))))))
|
||||
(send! (ethernet-packet interface
|
||||
#f
|
||||
(ethernet-interface-hwaddr interface)
|
||||
destination-hwaddr
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
|
||||
(require syndicate/protocol/advertise)
|
||||
|
||||
|
@ -19,7 +19,7 @@
|
|||
(struct present (who) #:prefab)
|
||||
|
||||
(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))))))
|
||||
|
||||
(define (say who fmt . vs)
|
||||
|
@ -27,65 +27,57 @@
|
|||
(send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
|
||||
(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 (asserted (present $who)) (say who "arrived."))
|
||||
(on (retracted (present $who)) (say who "departed."))
|
||||
(on (message (says $who $what)) (say who "says: ~a" what))
|
||||
|
||||
(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 _))))
|
||||
(on (message (inbound (tcp-channel them us $bs)))
|
||||
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))
|
||||
|
||||
(define us (tcp-listener 5999))
|
||||
(dataspace #:name 'chat-dataspace
|
||||
(spawn #:name 'chat-server
|
||||
(assert (outbound (advertise (observe (tcp-channel _ us _)))))
|
||||
(on (asserted (inbound (advertise (tcp-channel $them us _))))
|
||||
(spawn-session them us)))))
|
||||
(dataspace (define us (tcp-listener 5999))
|
||||
(forever (assert (outbound (advertise (observe (tcp-channel _ us _)))))
|
||||
(on (asserted (inbound (advertise (tcp-channel $them us _))))
|
||||
(spawn-session them us)))))
|
||||
|
||||
(let ((dst (udp-listener 6667)))
|
||||
(spawn #:name 'udp-echo-program
|
||||
(on (message (udp-packet $src dst $body))
|
||||
(log-info "Got packet from ~v: ~v" src body)
|
||||
(send! (udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body)))))))
|
||||
(actor (react
|
||||
(on (message (udp-packet $src dst $body))
|
||||
(log-info "Got packet from ~v: ~v" src body)
|
||||
(send! (udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body))))))))
|
||||
|
||||
(let ()
|
||||
(dataspace #:name 'webserver-dataspace
|
||||
(spawn #:name 'webserver-counter
|
||||
(field [counter 0])
|
||||
(on (message 'bump)
|
||||
(send! `(counter ,(counter)))
|
||||
(counter (+ (counter) 1))))
|
||||
(dataspace
|
||||
(actor (react (field [counter 0])
|
||||
(on (message 'bump)
|
||||
(send! `(counter ,(counter)))
|
||||
(counter (+ (counter) 1)))))
|
||||
|
||||
(define us (tcp-listener 80))
|
||||
(spawn (assert (outbound (advertise (observe (tcp-channel _ us _)))))
|
||||
(during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
|
||||
#:name (list 'webserver-session them)
|
||||
(log-info "Got connection from ~v" them)
|
||||
(assert (outbound (advertise (tcp-channel us them _))))
|
||||
(on (message (inbound (tcp-channel them us _)))) ;; ignore input
|
||||
(forever (define us (tcp-listener 80))
|
||||
(assert (outbound (advertise (observe (tcp-channel _ us _)))))
|
||||
(during/actor (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
|
||||
(log-info "Got connection from ~v" them)
|
||||
(field [done? #f])
|
||||
(stop-when (rising-edge (done?)))
|
||||
(assert (outbound (advertise (tcp-channel us them _))))
|
||||
(on (message (inbound (tcp-channel them us _)))) ;; ignore input
|
||||
|
||||
(on-start (send! 'bump))
|
||||
(on (message `(counter ,$counter))
|
||||
(define response
|
||||
(string->bytes/utf-8
|
||||
(format (string-append
|
||||
"HTTP/1.0 200 OK\r\n"
|
||||
"Content-Type: text/html\r\n"
|
||||
"\r\n"
|
||||
"<h1>Hello world from syndicate-netstack!</h1>\n"
|
||||
"<p>This is running on syndicate's own\n"
|
||||
"<a href='https://github.com/tonyg/syndicate/'>\n"
|
||||
"TCP/IP stack</a>.</p>\n"
|
||||
"<p>There have been ~a requests prior to this one.</p>\n")
|
||||
counter)))
|
||||
(send! (outbound (tcp-channel us them response)))
|
||||
(for [(i 4)]
|
||||
(define buf (make-bytes 1024 (+ #x30 i)))
|
||||
(send! (outbound (tcp-channel us them buf))))
|
||||
(stop-facet (current-facet-id)))))))
|
||||
(on-start (send! 'bump))
|
||||
(on (message `(counter ,$counter))
|
||||
(define response
|
||||
(string->bytes/utf-8
|
||||
(format (string-append
|
||||
"HTTP/1.0 200 OK\r\n\r\n"
|
||||
"<h1>Hello world from syndicate-netstack!</h1>\n"
|
||||
"<p>This is running on syndicate's own\n"
|
||||
"<a href='https://github.com/tonyg/syndicate/'>\n"
|
||||
"TCP/IP stack</a>.</p>\n"
|
||||
"<p>There have been ~a requests prior to this one.</p>\n")
|
||||
counter)))
|
||||
(send! (outbound (tcp-channel us them response)))
|
||||
(done? #t))))))
|
||||
|
|
|
@ -1,67 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Simple "ping" responder. Nightmarishly oversimplified. We want to
|
||||
;; look at overheads excluding Syndicate. See also
|
||||
;; http://dunkels.com/adam/twip.html
|
||||
|
||||
(require packet-socket)
|
||||
|
||||
(require "dump-bytes.rkt")
|
||||
|
||||
(define device-name (or (getenv "PINGRESP_DEVICE") "eth0"))
|
||||
(define self-ip (integer-bytes->integer (bytes 129 10 115 94) #f #t))
|
||||
|
||||
(define handle (raw-interface-open device-name))
|
||||
(unless handle (error 'pingresp "Couldn't open ~a" device-name))
|
||||
|
||||
(let loop ()
|
||||
(define eth-buffer (raw-interface-read handle))
|
||||
(define buffer (subbytes eth-buffer 14))
|
||||
(when (>= (bytes-length buffer) 20) ;; enough space for local and remote IP addresses
|
||||
(define local-ip (integer-bytes->integer buffer #f #t 16 20))
|
||||
(define remote-ip (integer-bytes->integer buffer #f #t 12 16))
|
||||
(when (= local-ip self-ip)
|
||||
;; (printf "Got ping from ~v\n" (bytes->list (subbytes buffer 12 16)))
|
||||
;; (flush-output)
|
||||
;; (dump-bytes! eth-buffer)
|
||||
;; (newline)
|
||||
|
||||
(when (and (>= (bytes-length buffer) 28) ;; IP + ICMP headers
|
||||
(= (bytes-ref buffer 9) 1) ;; IP protocol
|
||||
(= (bytes-ref buffer 20) 8) ;; ICMP ECHO
|
||||
)
|
||||
|
||||
(bytes-set! buffer 20 0) ;; ICMP ECHO_REPLY
|
||||
(integer->integer-bytes (bitwise-and #xffff
|
||||
(+ #x0800
|
||||
(integer-bytes->integer buffer #f #t 22 24)))
|
||||
2 #f #t buffer 22) ;; "fix" checksum
|
||||
(integer->integer-bytes local-ip 4 #f #t buffer 12)
|
||||
(integer->integer-bytes remote-ip 4 #f #t buffer 16)
|
||||
|
||||
(define reply
|
||||
(bytes-append (subbytes eth-buffer 6 12)
|
||||
(subbytes eth-buffer 0 6)
|
||||
(subbytes eth-buffer 12 14)
|
||||
buffer))
|
||||
;; (displayln "Reply:")
|
||||
;; (dump-bytes! reply)
|
||||
;; (newline)
|
||||
(raw-interface-write handle reply))))
|
||||
(loop))
|
||||
|
||||
(raw-interface-close handle)
|
||||
|
||||
|
||||
;; short s[70];
|
||||
;; int *l = s;
|
||||
;; int t;
|
||||
;;
|
||||
;; read(0, s, 140);
|
||||
;; if((s[4] & 65280) == 256 & s[10] == 8) {
|
||||
;; s[10] = 0;
|
||||
;; s[11] += 8;
|
||||
;; t = l[4];
|
||||
;; l[4] = l[3];
|
||||
;; l[3] = t;
|
||||
;; write(1, s, 140);
|
||||
;; }
|
|
@ -1,4 +1,4 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
;; UDP/TCP port allocator
|
||||
|
||||
(provide spawn-port-allocator
|
||||
|
@ -13,21 +13,22 @@
|
|||
(struct port-allocation-reply (reqid port) #:prefab)
|
||||
|
||||
(define (spawn-port-allocator allocator-type query-used-ports)
|
||||
(spawn #:name (list 'port-allocator allocator-type)
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
(define used-ports (query-used-ports))
|
||||
(actor #:name (list 'port-allocator allocator-type)
|
||||
(react
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
(define used-ports (query-used-ports))
|
||||
|
||||
(begin/dataflow
|
||||
(log-info "port-allocator ~v used ports: ~v" allocator-type (used-ports)))
|
||||
(begin/dataflow
|
||||
(log-info "port-allocator ~v used ports: ~v" allocator-type (used-ports)))
|
||||
|
||||
(on (message (port-allocation-request $reqid allocator-type))
|
||||
(define currently-used-ports (used-ports))
|
||||
(let randomly-allocate-until-unused ()
|
||||
(define p (+ 1024 (random 64512)))
|
||||
(if (set-member? currently-used-ports p)
|
||||
(randomly-allocate-until-unused)
|
||||
(begin (used-ports (set-add currently-used-ports p))
|
||||
(send! (port-allocation-reply reqid p))))))))
|
||||
(on (message (port-allocation-request $reqid allocator-type))
|
||||
(define currently-used-ports (used-ports))
|
||||
(let randomly-allocate-until-unused ()
|
||||
(define p (+ 1024 (random 64512)))
|
||||
(if (set-member? currently-used-ports p)
|
||||
(randomly-allocate-until-unused)
|
||||
(begin (used-ports (set-add currently-used-ports p))
|
||||
(send! (port-allocation-reply reqid p)))))))))
|
||||
|
||||
(define (allocate-port! type)
|
||||
(define reqid (gensym 'allocate-port!))
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -1,4 +1,4 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
|
||||
(provide (struct-out udp-remote-address)
|
||||
(struct-out udp-handle)
|
||||
|
@ -50,46 +50,46 @@
|
|||
(define (spawn-udp-driver)
|
||||
(spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p)))
|
||||
(spawn-kernel-udp-driver)
|
||||
(spawn #:name 'udp-driver
|
||||
(on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _)))
|
||||
(spawn-udp-relay (udp-listener-port h) h))
|
||||
(on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _)))
|
||||
(spawn #:name (list 'udp-transient h)
|
||||
(on-start (spawn-udp-relay (allocate-port! 'udp) h))))))
|
||||
(actor #:name 'udp-driver
|
||||
(react (on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _)))
|
||||
(spawn-udp-relay (udp-listener-port h) h))
|
||||
(on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _)))
|
||||
(actor #:name (list 'udp-transient h)
|
||||
(spawn-udp-relay (allocate-port! 'udp) h))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Relaying
|
||||
|
||||
(define (spawn-udp-relay local-port local-user-addr)
|
||||
(spawn #:name (list 'udp-relay local-port local-user-addr)
|
||||
(on-start (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr))
|
||||
(actor #:name (list 'udp-relay local-port local-user-addr)
|
||||
(log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr)
|
||||
|
||||
(define any-remote (udp-remote-address ? ?))
|
||||
|
||||
(stop-when (retracted (observe (udp-packet any-remote local-user-addr _))))
|
||||
(assert (advertise (udp-packet any-remote local-user-addr _)))
|
||||
(assert (udp-port-allocation local-port local-user-addr))
|
||||
(react (stop-when (retracted (observe (udp-packet any-remote local-user-addr _))))
|
||||
(assert (advertise (udp-packet any-remote local-user-addr _)))
|
||||
(assert (udp-port-allocation local-port local-user-addr))
|
||||
|
||||
(during (host-route $ip _ _)
|
||||
(assert (advertise (udp-datagram ip local-port _ _ _)))
|
||||
(on (message (udp-datagram $source-ip $source-port ip local-port $bs))
|
||||
(send!
|
||||
(udp-packet (udp-remote-address (ip-address->hostname source-ip)
|
||||
source-port)
|
||||
local-user-addr
|
||||
bs))))
|
||||
(during (host-route $ip _ _)
|
||||
(assert (advertise (udp-datagram ip local-port _ _ _)))
|
||||
(on (message (udp-datagram $source-ip $source-port ip local-port $bs))
|
||||
(send!
|
||||
(udp-packet (udp-remote-address (ip-address->hostname source-ip)
|
||||
source-port)
|
||||
local-user-addr
|
||||
bs))))
|
||||
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
(on (message (udp-packet local-user-addr ($ remote-addr any-remote) $bs))
|
||||
;; Choose arbitrary local IP address for outbound packet!
|
||||
;; TODO: what can be done? Must I examine the routing table?
|
||||
(match-define (udp-remote-address remote-host remote-port) remote-addr)
|
||||
(define remote-ip (ip-string->ip-address remote-host))
|
||||
(send! (udp-datagram (set-first (local-ips))
|
||||
local-port
|
||||
remote-ip
|
||||
remote-port
|
||||
bs)))))
|
||||
(define local-ips (query-local-ip-addresses))
|
||||
(on (message (udp-packet local-user-addr ($ remote-addr any-remote) $bs))
|
||||
;; Choose arbitrary local IP address for outbound packet!
|
||||
;; TODO: what can be done? Must I examine the routing table?
|
||||
(match-define (udp-remote-address remote-host remote-port) remote-addr)
|
||||
(define remote-ip (ip-string->ip-address remote-host))
|
||||
(send! (udp-datagram (set-first (local-ips))
|
||||
local-port
|
||||
remote-ip
|
||||
remote-port
|
||||
bs))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Codec & kernel-level driver
|
||||
|
@ -97,45 +97,46 @@
|
|||
(define PROTOCOL-UDP 17)
|
||||
|
||||
(define (spawn-kernel-udp-driver)
|
||||
(spawn #:name 'kernel-udp-driver
|
||||
(assert (advertise (ip-packet #f _ _ PROTOCOL-UDP _ _)))
|
||||
(actor #:name 'kernel-udp-driver
|
||||
(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))
|
||||
(when (and source-if (set-member? (local-ips) dst-ip))
|
||||
(bit-string-case body
|
||||
([ (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
(length :: integer bytes 2)
|
||||
(checksum :: integer bytes 2) ;; TODO: check checksum
|
||||
(data :: binary) ]
|
||||
(bit-string-case data
|
||||
([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes
|
||||
(:: binary) ]
|
||||
(send! (udp-datagram src-ip src-port dst-ip dst-port
|
||||
(bit-string->bytes payload))))
|
||||
(else #f)))
|
||||
(else #f))))
|
||||
(on (message (ip-packet $source-if $src-ip $dst-ip PROTOCOL-UDP _ $body))
|
||||
(when (and source-if (set-member? (local-ips) dst-ip))
|
||||
(bit-string-case body
|
||||
([ (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
(length :: integer bytes 2)
|
||||
(checksum :: integer bytes 2) ;; TODO: check checksum
|
||||
(data :: binary) ]
|
||||
(bit-string-case data
|
||||
([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes
|
||||
(:: binary) ]
|
||||
(send! (udp-datagram src-ip src-port dst-ip dst-port
|
||||
(bit-string->bytes payload))))
|
||||
(else #f)))
|
||||
(else #f))))
|
||||
|
||||
(on (message (udp-datagram $src-ip $src-port $dst-ip $dst-port $bs))
|
||||
(when (set-member? (local-ips) src-ip)
|
||||
(let* ((payload (bit-string (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
((+ 8 (bit-string-byte-count bs))
|
||||
:: integer bytes 2)
|
||||
(0 :: integer bytes 2) ;; checksum location
|
||||
(bs :: binary)))
|
||||
(pseudo-header (bit-string (src-ip :: binary bytes 4)
|
||||
(dst-ip :: binary bytes 4)
|
||||
0
|
||||
PROTOCOL-UDP
|
||||
((bit-string-byte-count payload)
|
||||
:: integer bytes 2)))
|
||||
(checksummed-payload (ip-checksum #:pseudo-header pseudo-header
|
||||
6 payload)))
|
||||
(send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #""
|
||||
checksummed-payload)))))))
|
||||
(on (message (udp-datagram $src-ip $src-port $dst-ip $dst-port $bs))
|
||||
(when (set-member? (local-ips) src-ip)
|
||||
(let* ((payload (bit-string (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
((+ 8 (bit-string-byte-count bs))
|
||||
:: integer bytes 2)
|
||||
(0 :: integer bytes 2) ;; checksum location
|
||||
(bs :: binary)))
|
||||
(pseudo-header (bit-string (src-ip :: binary bytes 4)
|
||||
(dst-ip :: binary bytes 4)
|
||||
0
|
||||
PROTOCOL-UDP
|
||||
((bit-string-byte-count payload)
|
||||
:: integer bytes 2)))
|
||||
(checksummed-payload (ip-checksum #:pseudo-header pseudo-header
|
||||
6 payload)))
|
||||
(send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #""
|
||||
checksummed-payload))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
@ -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
|
|
@ -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)
|
|
@ -215,7 +215,7 @@
|
|||
(cache-key-address q)))))))
|
||||
|
||||
(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)
|
||||
(match e
|
||||
[(scn g)
|
||||
|
|
|
@ -4,23 +4,22 @@
|
|||
(require racket/match)
|
||||
(require syndicate/monolithic)
|
||||
(require (only-in mzlib/os gethostname))
|
||||
(require (only-in racket/string string-split))
|
||||
(require "configuration.rkt")
|
||||
|
||||
(provide spawn-demo-config)
|
||||
|
||||
(define (spawn-demo-config)
|
||||
(actor (lambda (e s) #f)
|
||||
(spawn (lambda (e s) #f)
|
||||
(void)
|
||||
(match (gethostname)
|
||||
["skip"
|
||||
(scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0"))
|
||||
(assertion (host-route (bytes 192 168 1 222) 24 "en0")))]
|
||||
[(or "hop" "walk")
|
||||
(scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0"))
|
||||
(assertion (host-route (bytes 192 168 1 222) 24 "wlan0")))]
|
||||
["stockholm.ccs.neu.edu"
|
||||
(scn/union (assertion (host-route (bytes 129 10 115 94) 24 "eth0"))
|
||||
(assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))]
|
||||
[other ;; assume a private network
|
||||
(define interface
|
||||
(match (car (string-split other "."))
|
||||
["skip" "en0"]
|
||||
["leap" "wlp4s0"] ;; wtf
|
||||
[_ "wlan0"]))
|
||||
(scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
|
||||
(assertion (host-route (bytes 192 168 1 222) 24 interface)))])))
|
||||
[else
|
||||
(error 'spawn-demo-config "No setup for hostname ~a" (gethostname))])))
|
||||
|
|
|
@ -47,7 +47,7 @@
|
|||
(log-info "Opened interface ~a, yielding handle ~v" interface-name h)
|
||||
(define control-ch (make-async-channel))
|
||||
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
|
||||
(actor (lambda (e h)
|
||||
(spawn (lambda (e h)
|
||||
(match e
|
||||
[(scn g)
|
||||
(if (trie-empty? g)
|
||||
|
|
|
@ -83,7 +83,7 @@
|
|||
network-addr
|
||||
netmask
|
||||
interface-name))
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(scn (? trie-empty?)) (quit)]
|
||||
[(message (ip-packet _ peer-address _ _ _ body))
|
||||
|
@ -143,7 +143,7 @@
|
|||
(and (positive? msk)
|
||||
(ip-address-in-subnet? addr net msk))))
|
||||
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(scn g)
|
||||
(define host-ips+netmasks (trie-project/set #:take 2 g host-route-projector))
|
||||
|
@ -202,7 +202,7 @@
|
|||
;; Normal IP route
|
||||
|
||||
(define (spawn-normal-ip-route the-route network netmask interface-name)
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(scn (? trie-empty?)) (quit)]
|
||||
[(message (ethernet-packet _ _ _ _ _ body))
|
||||
|
|
|
@ -34,7 +34,7 @@
|
|||
(define (say who fmt . vs)
|
||||
(unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
(list (send-to-remote "Welcome, ~a.\n" user)
|
||||
(actor
|
||||
(spawn
|
||||
(lambda (e peers)
|
||||
(match e
|
||||
[(message (inbound (tcp-channel _ _ bs)))
|
||||
|
@ -61,14 +61,14 @@
|
|||
(advertisement (inbound (tcp-channel us them ?))) ;; we will write to remote client
|
||||
))))
|
||||
|
||||
(dataspace-actor
|
||||
(spawn-dataspace
|
||||
(spawn-demand-matcher (inbound (advertise (tcp-channel (?!) (?! (tcp-listener 5999)) ?)))
|
||||
(inbound (observe (tcp-channel (?!) (?! (tcp-listener 5999)) ?)))
|
||||
spawn-session))
|
||||
)
|
||||
|
||||
(let ()
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(message (udp-packet src dst body))
|
||||
(log-info "Got packet from ~v: ~v" src body)
|
||||
|
@ -84,7 +84,7 @@
|
|||
(define (spawn-session them us)
|
||||
(list
|
||||
(message 'bump)
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(message `(counter ,counter))
|
||||
(define response
|
||||
|
@ -105,8 +105,8 @@
|
|||
(subscription (inbound (advertise (tcp-channel them us ?))))
|
||||
(advertisement (inbound (tcp-channel us them ?)))))))
|
||||
|
||||
(dataspace-actor
|
||||
(actor (lambda (e counter)
|
||||
(spawn-dataspace
|
||||
(spawn (lambda (e counter)
|
||||
(match e
|
||||
[(message 'bump)
|
||||
(transition (+ counter 1) (message `(counter ,counter)))]
|
||||
|
|
|
@ -10,14 +10,14 @@
|
|||
;; -> Action
|
||||
;; Spawns a process that observes the given projections. Any time the
|
||||
;; environment's interests change in a relevant way, calls
|
||||
;; check-and-maybe-actor-fn with the aggregate interests and the
|
||||
;; projection results. If check-and-maybe-actor-fn returns #f,
|
||||
;; check-and-maybe-spawn-fn with the aggregate interests and the
|
||||
;; projection results. If check-and-maybe-spawn-fn returns #f,
|
||||
;; continues to wait; otherwise, takes the action(s) returned, and
|
||||
;; quits.
|
||||
(define (on-claim #:timeout-msec [timeout-msec #f]
|
||||
#:on-timeout [timeout-handler (lambda () '())]
|
||||
#:name [name #f]
|
||||
check-and-maybe-actor-fn
|
||||
check-and-maybe-spawn-fn
|
||||
base-interests
|
||||
. projections)
|
||||
(define timer-id (gensym 'on-claim))
|
||||
|
@ -27,18 +27,18 @@
|
|||
(define projection-results
|
||||
(map (lambda (p) (trie-project/set #:take (projection-arity p) new-aggregate p))
|
||||
projections))
|
||||
(define maybe-actor (apply check-and-maybe-actor-fn
|
||||
(define maybe-spawn (apply check-and-maybe-spawn-fn
|
||||
new-aggregate
|
||||
projection-results))
|
||||
(if maybe-actor
|
||||
(quit maybe-actor)
|
||||
(if maybe-spawn
|
||||
(quit maybe-spawn)
|
||||
#f)]
|
||||
[(message (timer-expired (== timer-id) _))
|
||||
(quit (timeout-handler))]
|
||||
[_ #f]))
|
||||
(list
|
||||
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
|
||||
(actor #:name name
|
||||
(spawn #:name name
|
||||
on-claim-handler
|
||||
(void)
|
||||
(scn/union base-interests
|
||||
|
|
|
@ -14,7 +14,7 @@
|
|||
(struct port-allocator-state (used-ports local-ips) #:transparent)
|
||||
|
||||
(define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports)
|
||||
(actor #:name (string->symbol (format "port-allocator:~a" allocator-type))
|
||||
(spawn #:name (string->symbol (format "port-allocator:~a" allocator-type))
|
||||
(lambda (e s)
|
||||
(match e
|
||||
[(scn g)
|
||||
|
|
|
@ -59,7 +59,7 @@
|
|||
(match-define (tcp-listener port) server-addr)
|
||||
;; TODO: have listener shut down once user-level listener does
|
||||
(list
|
||||
(actor #:name (string->symbol
|
||||
(spawn #:name (string->symbol
|
||||
(format "tcp-listener-port-reservation:~a" port))
|
||||
(lambda (e s) #f)
|
||||
(void)
|
||||
|
@ -122,7 +122,7 @@
|
|||
(define remote-peer-traffic (?! (advertise (tcp-channel remote-addr local-tcp-addr ?))))
|
||||
(list
|
||||
(message (set-timer timer-name relay-peer-wait-time-msec 'relative))
|
||||
(actor #:name (string->symbol (format "tcp-relay:~v:~v:~v"
|
||||
(spawn #:name (string->symbol (format "tcp-relay:~v:~v:~v"
|
||||
local-user-addr
|
||||
remote-addr
|
||||
local-tcp-addr))
|
||||
|
@ -294,7 +294,7 @@
|
|||
(transition s (message (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
|
||||
(ip-checksum 16 payload #:pseudo-header pseudo-header)))))
|
||||
|
||||
(actor #:name 'kernel-tcp-driver
|
||||
(spawn #:name 'kernel-tcp-driver
|
||||
(lambda (e s)
|
||||
(match e
|
||||
[(scn g)
|
||||
|
@ -655,7 +655,7 @@
|
|||
(current-inexact-milliseconds)
|
||||
#f
|
||||
#f)))
|
||||
(actor #:name
|
||||
(spawn #:name
|
||||
(string->symbol (format "tcp-state-vector:~a:~a:~a:~a"
|
||||
(ip-address->hostname src-ip)
|
||||
src-port
|
||||
|
|
|
@ -92,7 +92,7 @@
|
|||
(subscription (udp-datagram ? ? ip local-port ?))
|
||||
(advertisement (udp-datagram ip local-port ? ? ?)))))
|
||||
|
||||
(actor (lambda (e local-ips)
|
||||
(spawn (lambda (e local-ips)
|
||||
(match e
|
||||
[(scn g)
|
||||
(define new-local-ips (gestalt->local-ip-addresses g))
|
||||
|
@ -124,7 +124,7 @@
|
|||
(define PROTOCOL-UDP 17)
|
||||
|
||||
(define (spawn-kernel-udp-driver)
|
||||
(actor (lambda (e local-ips)
|
||||
(spawn (lambda (e local-ips)
|
||||
(match e
|
||||
[(scn g)
|
||||
(transition (gestalt->local-ip-addresses g) '())]
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
|
||||
(require racket/file)
|
||||
(require racket/serialize)
|
||||
|
@ -6,7 +6,6 @@
|
|||
(require operational-transformation)
|
||||
(require operational-transformation/text/simple-document)
|
||||
|
||||
(require syndicate/protocol/advertise)
|
||||
(require/activate syndicate/drivers/tcp)
|
||||
(require/activate syndicate/drivers/line-reader)
|
||||
|
||||
|
@ -18,47 +17,47 @@
|
|||
(define cmdline-port (make-parameter 5889))
|
||||
(define cmdline-filenames (make-parameter '()))
|
||||
|
||||
(spawn* (for [(filename (cmdline-filenames))]
|
||||
(run-one-server filename)))
|
||||
(actor (for [(filename (cmdline-filenames))]
|
||||
(run-one-server filename)))
|
||||
|
||||
(define (run-one-server filename)
|
||||
(spawn (field [state (make-server (simple-document
|
||||
(if (file-exists? filename)
|
||||
(begin (log-info "loading ~v" filename)
|
||||
(file->string filename))
|
||||
(begin (log-info "will create ~v" filename)
|
||||
""))))])
|
||||
(assert (snapshot-for filename (extract-snapshot (state))))
|
||||
(actor (react (field [state (make-server (simple-document
|
||||
(if (file-exists? filename)
|
||||
(begin (log-info "loading ~v" filename)
|
||||
(file->string filename))
|
||||
(begin (log-info "will create ~v" filename)
|
||||
""))))])
|
||||
(assert (snapshot-for filename (extract-snapshot (state))))
|
||||
|
||||
(define/query-set client-seen-revs (client-seen-up-to filename $rev) rev)
|
||||
(field [oldest-needed-rev #f])
|
||||
(begin/dataflow
|
||||
(define min-rev
|
||||
(or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
|
||||
(min (or min-rev rev) rev))
|
||||
(server-state-revision (state))))
|
||||
(when (not (equal? (oldest-needed-rev) min-rev))
|
||||
(oldest-needed-rev min-rev)
|
||||
(state (forget-operation-history (state) min-rev))))
|
||||
(define/query-set client-seen-revs (client-seen-up-to filename $rev) rev)
|
||||
(field [oldest-needed-rev #f])
|
||||
(begin/dataflow
|
||||
(define min-rev
|
||||
(or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
|
||||
(min (or min-rev rev) rev))
|
||||
(server-state-revision (state))))
|
||||
(when (not (equal? (oldest-needed-rev) min-rev))
|
||||
(oldest-needed-rev min-rev)
|
||||
(state (forget-operation-history (state) min-rev))))
|
||||
|
||||
(begin/dataflow
|
||||
(display-to-file (simple-document-text (server-state-document (state)))
|
||||
filename
|
||||
#:exists 'replace))
|
||||
(begin/dataflow
|
||||
(display-to-file (simple-document-text (server-state-document (state)))
|
||||
filename
|
||||
#:exists 'replace))
|
||||
|
||||
(on (message (proposed-op filename $p))
|
||||
(state (incorporate-operation-from-client (state) p))
|
||||
(define sp (extract-operation (state)))
|
||||
(when sp (send! (accepted-op filename sp))))))
|
||||
(on (message (proposed-op filename $p))
|
||||
(state (incorporate-operation-from-client (state) p))
|
||||
(define sp (extract-operation (state)))
|
||||
(when sp (send! (accepted-op filename sp)))))))
|
||||
|
||||
(spawn (define s (tcp-listener (cmdline-port)))
|
||||
(on-start (log-info "listening on port ~v" (cmdline-port)))
|
||||
(assert (advertise (observe (tcp-channel _ s _))))
|
||||
(during/spawn (advertise (tcp-channel $c s _))
|
||||
(assert (advertise (tcp-channel s c _)))
|
||||
(on-start (log-info "~a: connected" c))
|
||||
(on-stop (log-info "~a: disconnected" c))
|
||||
(connection-react c s)))
|
||||
(actor (define s (tcp-listener (cmdline-port)))
|
||||
(log-info "listening on port ~v" (cmdline-port))
|
||||
(forever (assert (advertise (observe (tcp-channel _ s _))))
|
||||
(during/actor (advertise (tcp-channel $c s _))
|
||||
(assert (advertise (tcp-channel s c _)))
|
||||
(on-start (log-info "~a: connected" c))
|
||||
(on-stop (log-info "~a: disconnected" c))
|
||||
(connection-react c s))))
|
||||
|
||||
(define (connection-react c s)
|
||||
(define (output v)
|
||||
|
@ -69,14 +68,13 @@
|
|||
(send! (tcp-channel s c (get-output-bytes p))))
|
||||
|
||||
(field [seen-up-to 0])
|
||||
(field [selected-filename #f])
|
||||
|
||||
(assert #:when (selected-filename) (client-seen-up-to (selected-filename) (seen-up-to)))
|
||||
|
||||
(define/query-set available-filenames (observe (proposed-op $f _)) f)
|
||||
(begin/dataflow
|
||||
(output (set->list (available-filenames))))
|
||||
|
||||
(field [selected-filename #f])
|
||||
(begin/dataflow
|
||||
(when (selected-filename)
|
||||
(log-info "~a: attached to file ~a" c (selected-filename))
|
||||
|
|
|
@ -1,11 +1,10 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
|
||||
(require racket/file)
|
||||
(require racket/serialize)
|
||||
(require operational-transformation)
|
||||
(require operational-transformation/text/simple-document)
|
||||
|
||||
(require syndicate/protocol/advertise)
|
||||
(require/activate syndicate/drivers/tcp)
|
||||
(require/activate syndicate/drivers/line-reader)
|
||||
|
||||
|
@ -16,43 +15,43 @@
|
|||
(define cmdline-port (make-parameter 5888))
|
||||
(define cmdline-filename (make-parameter "info.rkt"))
|
||||
|
||||
(spawn (field [state (make-server (simple-document
|
||||
(if (file-exists? (cmdline-filename))
|
||||
(begin (log-info "loading ~v" (cmdline-filename))
|
||||
(file->string (cmdline-filename)))
|
||||
(begin (log-info "will create ~v" (cmdline-filename))
|
||||
""))))])
|
||||
(assert (extract-snapshot (state)))
|
||||
(actor (react (field [state (make-server (simple-document
|
||||
(if (file-exists? (cmdline-filename))
|
||||
(begin (log-info "loading ~v" (cmdline-filename))
|
||||
(file->string (cmdline-filename)))
|
||||
(begin (log-info "will create ~v" (cmdline-filename))
|
||||
""))))])
|
||||
(assert (extract-snapshot (state)))
|
||||
|
||||
(define/query-set client-seen-revs (client-seen-up-to $rev) rev)
|
||||
(field [oldest-needed-rev #f])
|
||||
(begin/dataflow
|
||||
(define min-rev
|
||||
(or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
|
||||
(min (or min-rev rev) rev))
|
||||
(server-state-revision (state))))
|
||||
(when (not (equal? (oldest-needed-rev) min-rev))
|
||||
(oldest-needed-rev min-rev)
|
||||
(state (forget-operation-history (state) min-rev))))
|
||||
(define/query-set client-seen-revs (client-seen-up-to $rev) rev)
|
||||
(field [oldest-needed-rev #f])
|
||||
(begin/dataflow
|
||||
(define min-rev
|
||||
(or (for/fold [(min-rev #f)] [(rev (client-seen-revs))]
|
||||
(min (or min-rev rev) rev))
|
||||
(server-state-revision (state))))
|
||||
(when (not (equal? (oldest-needed-rev) min-rev))
|
||||
(oldest-needed-rev min-rev)
|
||||
(state (forget-operation-history (state) min-rev))))
|
||||
|
||||
(begin/dataflow
|
||||
(display-to-file (simple-document-text (server-state-document (state)))
|
||||
(cmdline-filename)
|
||||
#:exists 'replace))
|
||||
(begin/dataflow
|
||||
(display-to-file (simple-document-text (server-state-document (state)))
|
||||
(cmdline-filename)
|
||||
#:exists 'replace))
|
||||
|
||||
(on (message (proposed-op $p))
|
||||
(state (incorporate-operation-from-client (state) p))
|
||||
(define sp (extract-operation (state)))
|
||||
(when sp (send! (accepted-op sp)))))
|
||||
(on (message (proposed-op $p))
|
||||
(state (incorporate-operation-from-client (state) p))
|
||||
(define sp (extract-operation (state)))
|
||||
(when sp (send! (accepted-op sp))))))
|
||||
|
||||
(spawn (define s (tcp-listener (cmdline-port)))
|
||||
(on-start (log-info "listening on port ~v" (cmdline-port)))
|
||||
(assert (advertise (observe (tcp-channel _ s _))))
|
||||
(during/spawn (advertise (tcp-channel $c s _))
|
||||
(assert (advertise (tcp-channel s c _)))
|
||||
(on-start (log-info "~a: connected" c))
|
||||
(on-stop (log-info "~a: disconnected" c))
|
||||
(connection-react c s (cmdline-filename))))
|
||||
(actor (define s (tcp-listener (cmdline-port)))
|
||||
(log-info "listening on port ~v" (cmdline-port))
|
||||
(forever (assert (advertise (observe (tcp-channel _ s _))))
|
||||
(during/actor (advertise (tcp-channel $c s _))
|
||||
(assert (advertise (tcp-channel s c _)))
|
||||
(on-start (log-info "~a: connected" c))
|
||||
(on-stop (log-info "~a: disconnected" c))
|
||||
(connection-react c s (cmdline-filename)))))
|
||||
|
||||
(define (connection-react c s filename)
|
||||
(define (output v)
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang syndicate
|
||||
#lang syndicate/actor
|
||||
|
||||
(require 2htdp/image)
|
||||
(require 2htdp/planetcute)
|
||||
|
@ -302,51 +302,53 @@
|
|||
;; SceneManager
|
||||
|
||||
(define (spawn-scene-manager)
|
||||
(spawn #:name 'scene-manager
|
||||
(actor #:name 'scene-manager
|
||||
(define backdrop (rectangle 1 1 "solid" "white"))
|
||||
|
||||
(define/query-value size (vector 0 0) (inbound (window $x $y)) (vector x y))
|
||||
(define/query-set osds ($ o (on-screen-display _ _ _)) o)
|
||||
(define/query-value offset (vector 0 0) (scroll-offset $v) v)
|
||||
(react
|
||||
(define/query-value size (vector 0 0) (inbound (window $x $y)) (vector x y))
|
||||
(define/query-set osds ($ o (on-screen-display _ _ _)) o)
|
||||
(define/query-value offset (vector 0 0) (scroll-offset $v) v)
|
||||
|
||||
(field [fullscreen? #f])
|
||||
(assert #:when (fullscreen?) (outbound 'fullscreen))
|
||||
(on (message (inbound (key-event #\f #t _)))
|
||||
(fullscreen? (not (fullscreen?))))
|
||||
(field [fullscreen? #f])
|
||||
(assert #:when (fullscreen?) (outbound 'fullscreen))
|
||||
(on (message (inbound (key-event #\f #t _)))
|
||||
(fullscreen? (not (fullscreen?))))
|
||||
|
||||
(define (compute-backdrop)
|
||||
(match-define (vector width height) (size))
|
||||
(match-define (vector ofs-x ofs-y) (offset))
|
||||
(define osd-blocks
|
||||
(for/list [(osd (in-set (osds)))]
|
||||
(match-define (on-screen-display raw-x raw-y (seal i)) osd)
|
||||
(define x (if (negative? raw-x) (+ width raw-x) raw-x))
|
||||
(define y (if (negative? raw-y) (+ height raw-y) raw-y))
|
||||
`(push-matrix (translate ,x ,y)
|
||||
(scale ,(image-width i) ,(image-height i))
|
||||
(texture ,i))))
|
||||
(scene (seal `((push-matrix
|
||||
(scale ,width ,height)
|
||||
(texture ,backdrop))
|
||||
(translate ,(- ofs-x) ,(- ofs-y))))
|
||||
(seal `((translate ,ofs-x ,ofs-y)
|
||||
,@osd-blocks))))
|
||||
(assert (outbound (compute-backdrop)))))
|
||||
(define (compute-backdrop)
|
||||
(match-define (vector width height) (size))
|
||||
(match-define (vector ofs-x ofs-y) (offset))
|
||||
(define osd-blocks
|
||||
(for/list [(osd (in-set (osds)))]
|
||||
(match-define (on-screen-display raw-x raw-y (seal i)) osd)
|
||||
(define x (if (negative? raw-x) (+ width raw-x) raw-x))
|
||||
(define y (if (negative? raw-y) (+ height raw-y) raw-y))
|
||||
`(push-matrix (translate ,x ,y)
|
||||
(scale ,(image-width i) ,(image-height i))
|
||||
(texture ,i))))
|
||||
(scene (seal `((push-matrix
|
||||
(scale ,width ,height)
|
||||
(texture ,backdrop))
|
||||
(translate ,(- ofs-x) ,(- ofs-y))))
|
||||
(seal `((translate ,ofs-x ,ofs-y)
|
||||
,@osd-blocks))))
|
||||
(assert (outbound (compute-backdrop))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ScoreKeeper
|
||||
|
||||
(define (spawn-score-keeper)
|
||||
(spawn #:name 'score-keeper
|
||||
(field [score 0])
|
||||
(assert (current-score (score)))
|
||||
(assert (outbound
|
||||
(on-screen-display -150 10
|
||||
(seal (text (format "Score: ~a" (score)) 24 "white")))))
|
||||
(on (message (add-to-score $delta))
|
||||
(score (+ (score) delta))
|
||||
(log-info "Score increased by ~a to ~a" delta (score))
|
||||
(play-sound-sequence 270304))))
|
||||
(actor #:name 'score-keeper
|
||||
(react
|
||||
(field [score 0])
|
||||
(assert (current-score (score)))
|
||||
(assert (outbound
|
||||
(on-screen-display -150 10
|
||||
(seal (text (format "Score: ~a" (score)) 24 "white")))))
|
||||
(on (message (add-to-score $delta))
|
||||
(score (+ (score) delta))
|
||||
(log-info "Score increased by ~a to ~a" delta (score))
|
||||
(play-sound-sequence 270304)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; PhysicsEngine
|
||||
|
@ -356,177 +358,178 @@
|
|||
(define gravity 0.004)
|
||||
|
||||
(define (spawn-physics-engine)
|
||||
(spawn #:name 'physics-engine
|
||||
(field [configs (hash)]
|
||||
[previous-positions (hash)]
|
||||
[previous-velocities (hash)]
|
||||
[positions (hash)]
|
||||
[velocities (hash)])
|
||||
(actor #:name 'physics-engine
|
||||
(react
|
||||
(field [configs (hash)]
|
||||
[previous-positions (hash)]
|
||||
[previous-velocities (hash)]
|
||||
[positions (hash)]
|
||||
[velocities (hash)])
|
||||
|
||||
(during (game-piece-configuration $id $initial-position $size $attrs)
|
||||
(on-start (configs
|
||||
(hash-set (configs) id
|
||||
(game-piece-configuration id initial-position size attrs))))
|
||||
(on-stop (configs (hash-remove (configs) id))
|
||||
(positions (hash-remove (positions) id))
|
||||
(velocities (hash-remove (velocities) id)))
|
||||
(assert (position id (hash-ref (positions) id initial-position) size)))
|
||||
(during (game-piece-configuration $id $initial-position $size $attrs)
|
||||
(on-start (configs
|
||||
(hash-set (configs) id
|
||||
(game-piece-configuration id initial-position size attrs))))
|
||||
(on-stop (configs (hash-remove (configs) id))
|
||||
(positions (hash-remove (positions) id))
|
||||
(velocities (hash-remove (velocities) id)))
|
||||
(assert (position id (hash-ref (positions) id initial-position) size)))
|
||||
|
||||
(define/query-hash impulses (impulse $id $vec) id vec)
|
||||
(define/query-hash impulses (impulse $id $vec) id vec)
|
||||
|
||||
(define (piece-cfg id) (hash-ref (configs) id))
|
||||
(define (piece-pos which id)
|
||||
(hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id)))))
|
||||
(define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0))))
|
||||
(define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0))))
|
||||
(define (piece-cfg id) (hash-ref (configs) id))
|
||||
(define (piece-pos which id)
|
||||
(hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id)))))
|
||||
(define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0))))
|
||||
(define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0))))
|
||||
|
||||
(define (update-piece! g new-pos new-vel)
|
||||
(positions (hash-set (positions) (game-piece-configuration-id g) new-pos))
|
||||
(velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel)))
|
||||
(define (update-piece! g new-pos new-vel)
|
||||
(positions (hash-set (positions) (game-piece-configuration-id g) new-pos))
|
||||
(velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel)))
|
||||
|
||||
(define (find-support p size which-pos)
|
||||
(match-define (vector p-left p-top) p)
|
||||
(match-define (vector p-w p-h) size)
|
||||
(define p-right (+ p-left p-w))
|
||||
(define p-bottom (+ p-top p-h))
|
||||
(for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
|
||||
(match-define (vector left top) (piece-pos which-pos id))
|
||||
(and (< (abs (- top p-bottom)) 0.5)
|
||||
(<= left p-right)
|
||||
(match (game-piece-configuration-size g)
|
||||
[(vector w h)
|
||||
(<= p-left (+ left w))])
|
||||
g)))
|
||||
(define (find-support p size which-pos)
|
||||
(match-define (vector p-left p-top) p)
|
||||
(match-define (vector p-w p-h) size)
|
||||
(define p-right (+ p-left p-w))
|
||||
(define p-bottom (+ p-top p-h))
|
||||
(for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
|
||||
(match-define (vector left top) (piece-pos which-pos id))
|
||||
(and (< (abs (- top p-bottom)) 0.5)
|
||||
(<= left p-right)
|
||||
(match (game-piece-configuration-size g)
|
||||
[(vector w h)
|
||||
(<= p-left (+ left w))])
|
||||
g)))
|
||||
|
||||
(define (segment-intersection-time p0 r q0 q1)
|
||||
;; See http://stackoverflow.com/a/565282/169231
|
||||
;; Enhanced to consider the direction of impact with the segment,
|
||||
;; too: only returns an intersection when the vector of motion is
|
||||
;; at an obtuse angle to the normal of the segment.
|
||||
(define s (v- q1 q0))
|
||||
(define rxs (vcross2 r s))
|
||||
(cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear)
|
||||
[else
|
||||
(define q-p (v- q0 p0))
|
||||
(define q-pxs (vcross2 q-p s))
|
||||
(define t (/ q-pxs rxs))
|
||||
(and (<= 0 t 1)
|
||||
(let* ((q-pxr (vcross2 q-p r))
|
||||
(u (/ q-pxr rxs)))
|
||||
(and (< 0 u 1)
|
||||
(let* ((q-norm
|
||||
(vnormalize (vector (vector-ref s 1) (- (vector-ref s 0))))))
|
||||
(and (not (positive? (vdot r q-norm)))
|
||||
(- t 0.001))))))]))
|
||||
(define (segment-intersection-time p0 r q0 q1)
|
||||
;; See http://stackoverflow.com/a/565282/169231
|
||||
;; Enhanced to consider the direction of impact with the segment,
|
||||
;; too: only returns an intersection when the vector of motion is
|
||||
;; at an obtuse angle to the normal of the segment.
|
||||
(define s (v- q1 q0))
|
||||
(define rxs (vcross2 r s))
|
||||
(cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear)
|
||||
[else
|
||||
(define q-p (v- q0 p0))
|
||||
(define q-pxs (vcross2 q-p s))
|
||||
(define t (/ q-pxs rxs))
|
||||
(and (<= 0 t 1)
|
||||
(let* ((q-pxr (vcross2 q-p r))
|
||||
(u (/ q-pxr rxs)))
|
||||
(and (< 0 u 1)
|
||||
(let* ((q-norm
|
||||
(vnormalize (vector (vector-ref s 1) (- (vector-ref s 0))))))
|
||||
(and (not (positive? (vdot r q-norm)))
|
||||
(- t 0.001))))))]))
|
||||
|
||||
(define (three-corners top-left size)
|
||||
(match-define (vector w h) size)
|
||||
(values (v+ top-left (vector w 0))
|
||||
(v+ top-left size)
|
||||
(v+ top-left (vector 0 h))))
|
||||
(define (three-corners top-left size)
|
||||
(match-define (vector w h) size)
|
||||
(values (v+ top-left (vector w 0))
|
||||
(v+ top-left size)
|
||||
(v+ top-left (vector 0 h))))
|
||||
|
||||
(define (clip-movement-by top-left moved-top-left size solid-top-left solid-size)
|
||||
(define-values (solid-top-right solid-bottom-right solid-bottom-left)
|
||||
(three-corners solid-top-left solid-size))
|
||||
(define-values (top-right bottom-right bottom-left)
|
||||
(three-corners top-left size))
|
||||
(define r (v- moved-top-left top-left))
|
||||
(define t
|
||||
(apply min
|
||||
(for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))]
|
||||
(min (or (segment-intersection-time p r solid-top-left solid-top-right) 1)
|
||||
;; TODO: some means of specifying *which edges* should appear solid.
|
||||
#;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1)
|
||||
#;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1)
|
||||
#;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1)))))
|
||||
(v+ top-left (v* r t)))
|
||||
(define (clip-movement-by top-left moved-top-left size solid-top-left solid-size)
|
||||
(define-values (solid-top-right solid-bottom-right solid-bottom-left)
|
||||
(three-corners solid-top-left solid-size))
|
||||
(define-values (top-right bottom-right bottom-left)
|
||||
(three-corners top-left size))
|
||||
(define r (v- moved-top-left top-left))
|
||||
(define t
|
||||
(apply min
|
||||
(for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))]
|
||||
(min (or (segment-intersection-time p r solid-top-left solid-top-right) 1)
|
||||
;; TODO: some means of specifying *which edges* should appear solid.
|
||||
#;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1)
|
||||
#;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1)
|
||||
#;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1)))))
|
||||
(v+ top-left (v* r t)))
|
||||
|
||||
(define (clip-movement-by-solids p0 p1 size)
|
||||
(for/fold [(p1 p1)]
|
||||
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
|
||||
(clip-movement-by p0 p1 size
|
||||
(piece-pos previous-positions id)
|
||||
(game-piece-configuration-size g))))
|
||||
(define (clip-movement-by-solids p0 p1 size)
|
||||
(for/fold [(p1 p1)]
|
||||
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)]
|
||||
(clip-movement-by p0 p1 size
|
||||
(piece-pos previous-positions id)
|
||||
(game-piece-configuration-size g))))
|
||||
|
||||
(define (touched-during-movement? TL moved-TL size touchable-TL touchable-size)
|
||||
(define r (v- moved-TL TL))
|
||||
(if (positive? (vmag^2 r)) ;; r is nonzero, in other words
|
||||
(let ()
|
||||
(define-values (touchable-TR touchable-BR touchable-BL)
|
||||
(three-corners touchable-TL touchable-size))
|
||||
(define-values (TR BR BL)
|
||||
(three-corners TL size))
|
||||
(for/or [(p (in-list (list TL TR BR BL)))]
|
||||
(or
|
||||
(and (segment-intersection-time p r touchable-TR touchable-BR) 'right)
|
||||
(and (segment-intersection-time p r touchable-BR touchable-BL) 'bottom)
|
||||
(and (segment-intersection-time p r touchable-BL touchable-TL) 'left)
|
||||
(and (segment-intersection-time p r touchable-TL touchable-TR) 'top))))
|
||||
(let ()
|
||||
(match-define (vector left top) TL)
|
||||
(match-define (vector touchable-left touchable-top) touchable-TL)
|
||||
(match-define (vector width height) size)
|
||||
(match-define (vector touchable-width touchable-height) touchable-size)
|
||||
(and (<= left (+ touchable-left touchable-width))
|
||||
(<= top (+ touchable-top touchable-height))
|
||||
(<= touchable-left (+ left width))
|
||||
(<= touchable-top (+ top height))
|
||||
'mid))))
|
||||
(define (touched-during-movement? TL moved-TL size touchable-TL touchable-size)
|
||||
(define r (v- moved-TL TL))
|
||||
(if (positive? (vmag^2 r)) ;; r is nonzero, in other words
|
||||
(let ()
|
||||
(define-values (touchable-TR touchable-BR touchable-BL)
|
||||
(three-corners touchable-TL touchable-size))
|
||||
(define-values (TR BR BL)
|
||||
(three-corners TL size))
|
||||
(for/or [(p (in-list (list TL TR BR BL)))]
|
||||
(or
|
||||
(and (segment-intersection-time p r touchable-TR touchable-BR) 'right)
|
||||
(and (segment-intersection-time p r touchable-BR touchable-BL) 'bottom)
|
||||
(and (segment-intersection-time p r touchable-BL touchable-TL) 'left)
|
||||
(and (segment-intersection-time p r touchable-TL touchable-TR) 'top))))
|
||||
(let ()
|
||||
(match-define (vector left top) TL)
|
||||
(match-define (vector touchable-left touchable-top) touchable-TL)
|
||||
(match-define (vector width height) size)
|
||||
(match-define (vector touchable-width touchable-height) touchable-size)
|
||||
(and (<= left (+ touchable-left touchable-width))
|
||||
(<= top (+ touchable-top touchable-height))
|
||||
(<= touchable-left (+ left width))
|
||||
(<= touchable-top (+ top height))
|
||||
'mid))))
|
||||
|
||||
(define (touchables-touched-during-movement p0 p1 size)
|
||||
(for/fold [(ts '())]
|
||||
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'touchable)]
|
||||
(define side (touched-during-movement? p0 p1 size
|
||||
(piece-pos previous-positions id)
|
||||
(game-piece-configuration-size g)))
|
||||
(if side (cons (cons side g) ts) ts)))
|
||||
(define (touchables-touched-during-movement p0 p1 size)
|
||||
(for/fold [(ts '())]
|
||||
[((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'touchable)]
|
||||
(define side (touched-during-movement? p0 p1 size
|
||||
(piece-pos previous-positions id)
|
||||
(game-piece-configuration-size g)))
|
||||
(if side (cons (cons side g) ts) ts)))
|
||||
|
||||
(define (update-game-piece! elapsed-ms id)
|
||||
(define g (piece-cfg id))
|
||||
(define size (game-piece-configuration-size g))
|
||||
(define pos0 (piece-pos previous-positions id))
|
||||
(define support (find-support pos0 size previous-positions))
|
||||
(define (update-game-piece! elapsed-ms id)
|
||||
(define g (piece-cfg id))
|
||||
(define size (game-piece-configuration-size g))
|
||||
(define pos0 (piece-pos previous-positions id))
|
||||
(define support (find-support pos0 size previous-positions))
|
||||
|
||||
(define vel0 (piece-vel previous-velocities id))
|
||||
(define imp0 (piece-imp id))
|
||||
(define vel0 (piece-vel previous-velocities id))
|
||||
(define imp0 (piece-imp id))
|
||||
|
||||
(define vel1 (cond
|
||||
[(and support (not (negative? (vector-ref vel0 1))))
|
||||
(piece-vel previous-velocities (game-piece-configuration-id support))]
|
||||
[(game-piece-has-attribute? g 'massive)
|
||||
(v+ vel0 (vector 0 (* gravity elapsed-ms)))]
|
||||
[else
|
||||
vel0]))
|
||||
(define vel1 (cond
|
||||
[(and support (not (negative? (vector-ref vel0 1))))
|
||||
(piece-vel previous-velocities (game-piece-configuration-id support))]
|
||||
[(game-piece-has-attribute? g 'massive)
|
||||
(v+ vel0 (vector 0 (* gravity elapsed-ms)))]
|
||||
[else
|
||||
vel0]))
|
||||
|
||||
(define pos1 (v+ pos0 (v* (v+ vel1 imp0) (* impulse-multiplier elapsed-ms))))
|
||||
(define final-pos (clip-movement-by-solids pos0 pos1 size))
|
||||
;; TODO: figure out how to cancel just the component of velocity blocked by the obstacle(s)
|
||||
;; - which will avoid the "sticking to the wall" artifact
|
||||
(define final-vel (if (v= pos1 final-pos) vel1 (vector 0 0))) ;; stop at collision
|
||||
(define touchables (touchables-touched-during-movement pos0 final-pos size))
|
||||
(define pos1 (v+ pos0 (v* (v+ vel1 imp0) (* impulse-multiplier elapsed-ms))))
|
||||
(define final-pos (clip-movement-by-solids pos0 pos1 size))
|
||||
;; TODO: figure out how to cancel just the component of velocity blocked by the obstacle(s)
|
||||
;; - which will avoid the "sticking to the wall" artifact
|
||||
(define final-vel (if (v= pos1 final-pos) vel1 (vector 0 0))) ;; stop at collision
|
||||
(define touchables (touchables-touched-during-movement pos0 final-pos size))
|
||||
|
||||
(retract! (touching id ? ?))
|
||||
(for [(t touchables)]
|
||||
(match-define (cons side tg) t)
|
||||
(assert! (touching id (game-piece-configuration-id tg) side)))
|
||||
(update-piece! g final-pos final-vel))
|
||||
(retract! (touching id ? ?))
|
||||
(for [(t touchables)]
|
||||
(match-define (cons side tg) t)
|
||||
(assert! (touching id (game-piece-configuration-id tg) side)))
|
||||
(update-piece! g final-pos final-vel))
|
||||
|
||||
(on (message (jump-request $id))
|
||||
(define g (piece-cfg id))
|
||||
(define pos (piece-pos positions id))
|
||||
(when (find-support pos (game-piece-configuration-size g) positions)
|
||||
(play-sound-sequence 270318)
|
||||
(update-piece! g pos jump-vel)))
|
||||
(on (message (jump-request $id))
|
||||
(define g (piece-cfg id))
|
||||
(define pos (piece-pos positions id))
|
||||
(when (find-support pos (game-piece-configuration-size g) positions)
|
||||
(play-sound-sequence 270318)
|
||||
(update-piece! g pos jump-vel)))
|
||||
|
||||
(on (message (inbound* game-level (frame-event $counter _ $elapsed-ms _)))
|
||||
(when (zero? (modulo counter 10))
|
||||
(log-info "Instantaneous frame rate at frame ~a: ~a Hz"
|
||||
counter
|
||||
(/ 1000.0 elapsed-ms)))
|
||||
(previous-positions (positions))
|
||||
(previous-velocities (velocities))
|
||||
(for [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'mobile)]
|
||||
(update-game-piece! elapsed-ms id)))))
|
||||
(on (message (inbound* game-level (frame-event $counter _ $elapsed-ms _)))
|
||||
(when (zero? (modulo counter 10))
|
||||
(log-info "Instantaneous frame rate at frame ~a: ~a Hz"
|
||||
counter
|
||||
(/ 1000.0 elapsed-ms)))
|
||||
(previous-positions (positions))
|
||||
(previous-velocities (velocities))
|
||||
(for [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'mobile)]
|
||||
(update-game-piece! elapsed-ms id))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Player
|
||||
|
@ -535,48 +538,50 @@
|
|||
(define planetcute-scale 1/2)
|
||||
|
||||
(define (spawn-player-avatar initial-focus-x initial-focus-y)
|
||||
(spawn #:name 'player-avatar
|
||||
(define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16))
|
||||
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
|
||||
(actor #:name 'player-avatar
|
||||
(react
|
||||
(define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16))
|
||||
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
|
||||
|
||||
(assert (game-piece-configuration player-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'player 'mobile 'massive)))
|
||||
(assert (game-piece-configuration player-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'player 'mobile 'massive)))
|
||||
|
||||
(define/query-value pos initial-top-left (position player-id $hitbox-top-left _)
|
||||
hitbox-top-left)
|
||||
(assert (outbound* game-level (icon-sprite i 0 (pos))))
|
||||
(define/query-value pos initial-top-left (position player-id $hitbox-top-left _)
|
||||
hitbox-top-left)
|
||||
(assert (outbound* game-level (icon-sprite i 0 (pos))))
|
||||
|
||||
(field [hit-points 1])
|
||||
(assert (health player-id (hit-points)))
|
||||
(stop-when-true (<= (hit-points) 0))
|
||||
(on (message (damage player-id $amount))
|
||||
(hit-points (- (hit-points) amount)))
|
||||
(field [hit-points 1])
|
||||
(assert (health player-id (hit-points)))
|
||||
(stop-when (rising-edge (<= (hit-points) 0)))
|
||||
(on (message (damage player-id $amount))
|
||||
(hit-points (- (hit-points) amount)))
|
||||
|
||||
(on (asserted (inbound* 2 (key-pressed #\space))) (send! (jump-request player-id)))
|
||||
(on (asserted (inbound* 2 (key-pressed #\.))) (send! (jump-request player-id)))
|
||||
(on (asserted (inbound* 2 (key-pressed #\space))) (send! (jump-request player-id)))
|
||||
(on (asserted (inbound* 2 (key-pressed #\.))) (send! (jump-request player-id)))
|
||||
|
||||
(define/query-set keys-down (inbound* 2 (key-pressed $k)) k)
|
||||
(define (any-key-down? . ks) (for/or [(k ks)] (set-member? (keys-down) k)))
|
||||
(assert (impulse player-id (vector (+ (if (any-key-down? 'left 'prior) -1 0)
|
||||
(if (any-key-down? 'right 'next) 1 0))
|
||||
0)))))
|
||||
(define/query-set keys-down (inbound* 2 (key-pressed $k)) k)
|
||||
(define (any-key-down? . ks) (for/or [(k ks)] (set-member? (keys-down) k)))
|
||||
(assert (impulse player-id (vector (+ (if (any-key-down? 'left 'prior) -1 0)
|
||||
(if (any-key-down? 'right 'next) 1 0))
|
||||
0))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Ground Block
|
||||
|
||||
(define (spawn-ground-block top-left size #:color [color "purple"])
|
||||
(spawn #:name (list 'ground-block top-left size color)
|
||||
(actor #:name (list 'ground-block top-left size color)
|
||||
(match-define (vector x y) top-left)
|
||||
(match-define (vector w h) size)
|
||||
(define block-id (gensym 'ground-block))
|
||||
(define block-pict (rectangle w h "solid" color))
|
||||
(assert (outbound* game-level (simple-sprite 0 x y w h block-pict)))
|
||||
(assert (game-piece-configuration block-id
|
||||
(react
|
||||
(assert (outbound* game-level (simple-sprite 0 x y w h block-pict)))
|
||||
(assert (game-piece-configuration block-id
|
||||
top-left
|
||||
size
|
||||
(set 'solid)))))
|
||||
(set 'solid))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Goal piece
|
||||
|
@ -589,14 +594,15 @@
|
|||
(define i (icon key planetcute-scale 1/3 2/5 4/5))
|
||||
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
|
||||
|
||||
(spawn #:name (list 'goal-piece initial-focus-x initial-focus-y)
|
||||
(on (asserted (touching player-id goal-id _))
|
||||
(send! (outbound (level-completed))))
|
||||
(assert (game-piece-configuration goal-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'touchable)))
|
||||
(assert (outbound* game-level (icon-sprite i -1 initial-top-left)))))
|
||||
(actor #:name (list 'goal-piece initial-focus-x initial-focus-y)
|
||||
(react
|
||||
(on (asserted (touching player-id goal-id _))
|
||||
(send! (outbound (level-completed))))
|
||||
(assert (game-piece-configuration goal-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'touchable)))
|
||||
(assert (outbound* game-level (icon-sprite i -1 initial-top-left))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Enemy
|
||||
|
@ -604,42 +610,43 @@
|
|||
(define (spawn-enemy initial-x initial-y range-lo range-hi
|
||||
#:speed [speed 0.2]
|
||||
#:facing [initial-facing 'right])
|
||||
(spawn #:name (list 'enemy initial-x initial-y initial-facing)
|
||||
(define enemy-id (gensym 'enemy))
|
||||
(define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6))
|
||||
(define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))]))
|
||||
(define initial-top-left (focus->top-left i initial-x initial-y))
|
||||
(match-define (vector width height) (icon-hitbox-size i))
|
||||
(actor #:name (list 'enemy initial-x initial-y initial-facing)
|
||||
(react
|
||||
(define enemy-id (gensym 'enemy))
|
||||
(define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6))
|
||||
(define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))]))
|
||||
(define initial-top-left (focus->top-left i initial-x initial-y))
|
||||
(match-define (vector width height) (icon-hitbox-size i))
|
||||
|
||||
(assert (game-piece-configuration enemy-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'mobile 'massive 'touchable)))
|
||||
(assert (game-piece-configuration enemy-id
|
||||
initial-top-left
|
||||
(icon-hitbox-size i)
|
||||
(set 'mobile 'massive 'touchable)))
|
||||
|
||||
(define/query-value current-level-size #f (level-size $v) v)
|
||||
(define/query-value current-level-size #f (level-size $v) v)
|
||||
|
||||
(define/query-value pos initial-top-left (position enemy-id $top-left _) top-left
|
||||
#:on-add (match-let (((vector left top) top-left))
|
||||
(facing (cond [(< left range-lo) 'right]
|
||||
[(> (+ left width) range-hi) 'left]
|
||||
[else (facing)]))))
|
||||
(define/query-value pos initial-top-left (position enemy-id $top-left _) top-left
|
||||
#:on-add (match-let (((vector left top) top-left))
|
||||
(facing (cond [(< left range-lo) 'right]
|
||||
[(> (+ left width) range-hi) 'left]
|
||||
[else (facing)]))))
|
||||
|
||||
(stop-when-true (and (current-level-size)
|
||||
(> (vector-ref (pos) 1)
|
||||
(vector-ref (current-level-size) 1))))
|
||||
(stop-when (rising-edge (and (current-level-size)
|
||||
(> (vector-ref (pos) 1)
|
||||
(vector-ref (current-level-size) 1)))))
|
||||
|
||||
(field [facing initial-facing])
|
||||
(assert (outbound* game-level
|
||||
(icon-sprite (match (facing) ['right i] ['left i-flipped]) -1 (pos))))
|
||||
(field [facing initial-facing])
|
||||
(assert (outbound* game-level
|
||||
(icon-sprite (match (facing) ['right i] ['left i-flipped]) -1 (pos))))
|
||||
|
||||
(assert (impulse enemy-id (vector (* speed (match (facing) ['right 1] ['left -1])) 0)))
|
||||
(assert (impulse enemy-id (vector (* speed (match (facing) ['right 1] ['left -1])) 0)))
|
||||
|
||||
(stop-when (asserted (touching player-id enemy-id 'top))
|
||||
(play-sound-sequence 270325)
|
||||
(send! (outbound (add-to-score 1))))
|
||||
(stop-when (asserted (touching player-id enemy-id 'top))
|
||||
(play-sound-sequence 270325)
|
||||
(send! (outbound (add-to-score 1))))
|
||||
|
||||
(on (asserted (touching player-id enemy-id $side))
|
||||
(when (not (eq? side 'top)) (send! (damage player-id 1))))))
|
||||
(on (asserted (touching player-id enemy-id $side))
|
||||
(when (not (eq? side 'top)) (send! (damage player-id 1)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; DisplayControl
|
||||
|
@ -647,22 +654,23 @@
|
|||
(define (spawn-display-controller level-size-vec)
|
||||
(match-define (vector level-width level-height) level-size-vec)
|
||||
|
||||
(spawn #:name 'display-controller
|
||||
(field [offset-pos (vector 0 0)])
|
||||
(assert (outbound* 2 (scroll-offset (offset-pos))))
|
||||
(assert (level-size level-size-vec))
|
||||
(actor #:name 'display-controller
|
||||
(react
|
||||
(field [offset-pos (vector 0 0)])
|
||||
(assert (outbound* 2 (scroll-offset (offset-pos))))
|
||||
(assert (level-size level-size-vec))
|
||||
|
||||
(define/query-value window-size-vec #f (inbound* game-level (window $w $h)) (vector w h))
|
||||
(define/query-value window-size-vec #f (inbound* game-level (window $w $h)) (vector w h))
|
||||
|
||||
(define (compute-offset pos viewport limit)
|
||||
(min (max 0 (- pos (/ viewport 2))) (- limit viewport)))
|
||||
(define (compute-offset pos viewport limit)
|
||||
(min (max 0 (- pos (/ viewport 2))) (- limit viewport)))
|
||||
|
||||
(on (asserted (position player-id (vector $px $py) _))
|
||||
(when (window-size-vec)
|
||||
(match-define (vector ww wh) (window-size-vec))
|
||||
(when (> py level-height) (send! (damage player-id +inf.0)))
|
||||
(offset-pos (vector (compute-offset px ww level-width)
|
||||
(compute-offset py wh level-height)))))))
|
||||
(on (asserted (position player-id (vector $px $py) _))
|
||||
(when (window-size-vec)
|
||||
(match-define (vector ww wh) (window-size-vec))
|
||||
(when (> py level-height) (send! (damage player-id +inf.0)))
|
||||
(offset-pos (vector (compute-offset px ww level-width)
|
||||
(compute-offset py wh level-height))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; LevelTerminationMonitor
|
||||
|
@ -671,24 +679,25 @@
|
|||
;; kills the dataspace.
|
||||
|
||||
(define (wait-for-level-termination)
|
||||
(spawn
|
||||
(assert (outbound (level-running)))
|
||||
(on (retracted (game-piece-configuration player-id _ _ _))
|
||||
(log-info "Player died! Terminating level.")
|
||||
(play-sound-sequence 270328)
|
||||
(quit-dataspace!))
|
||||
(on (message (inbound (level-completed)))
|
||||
(log-info "Level completed! Terminating level.")
|
||||
(play-sound-sequence 270330)
|
||||
(send! (outbound (add-to-score 100)))
|
||||
(quit-dataspace!))))
|
||||
(react/suspend (done)
|
||||
(assert (outbound (level-running)))
|
||||
(stop-when (retracted (game-piece-configuration player-id _ _ _))
|
||||
(log-info "Player died! Terminating level.")
|
||||
(play-sound-sequence 270328)
|
||||
(done))
|
||||
(stop-when (message (inbound (level-completed)))
|
||||
(log-info "Level completed! Terminating level.")
|
||||
(play-sound-sequence 270330)
|
||||
(send! (outbound (add-to-score 100)))
|
||||
(done))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; LevelSpawner
|
||||
|
||||
(define (spawn-standalone-assertions . patches)
|
||||
(spawn #:name 'standalone-assertions
|
||||
(on-start (patch! (patch-seq* patches)))))
|
||||
(actor #:name 'standalone-assertions
|
||||
(patch! (patch-seq* patches))
|
||||
(forever)))
|
||||
|
||||
(define (spawn-background-image level-size scene)
|
||||
(match-define (vector level-width level-height) level-size)
|
||||
|
@ -778,18 +787,18 @@
|
|||
message))))))
|
||||
|
||||
(define (spawn-level-spawner starting-level)
|
||||
(spawn #:name 'level-spawner
|
||||
(field [current-level starting-level]
|
||||
[level-complete? #f])
|
||||
(actor #:name 'level-spawner
|
||||
(react (field [current-level starting-level]
|
||||
[level-complete? #f])
|
||||
|
||||
(on (message (level-completed)) (level-complete? #t))
|
||||
(on (message (level-completed)) (level-complete? #t))
|
||||
|
||||
(on (retracted (level-running))
|
||||
(current-level (if (level-complete?) (+ (current-level) 1) (current-level)))
|
||||
(level-complete? #f)
|
||||
(spawn-numbered-level (current-level)))
|
||||
(on (retracted (level-running))
|
||||
(current-level (if (level-complete?) (+ (current-level) 1) (current-level)))
|
||||
(level-complete? #f)
|
||||
(spawn-numbered-level (current-level)))
|
||||
|
||||
(on-start (spawn-numbered-level starting-level))))
|
||||
(on-start (spawn-numbered-level starting-level)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Sounds
|
||||
|
@ -816,4 +825,5 @@
|
|||
(spawn-keyboard-integrator)
|
||||
(spawn-scene-manager)
|
||||
(dataspace (spawn-score-keeper)
|
||||
(spawn-level-spawner 0))
|
||||
(spawn-level-spawner 0)
|
||||
(forever))
|
||||
|
|
|
@ -335,7 +335,7 @@
|
|||
p
|
||||
(?! (on-screen-display ? ? ?)))]))
|
||||
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(? patch? p)
|
||||
(let* ((s (update-window-size s p))
|
||||
|
@ -381,7 +381,7 @@
|
|||
(define i (text (format "Score: ~a" new-score) 24 "white"))
|
||||
(patch-seq (retract (outbound (on-screen-display ? ? ?)))
|
||||
(assert (outbound (on-screen-display -150 10 (seal i))))))
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(message (add-to-score delta))
|
||||
(define new-score (+ s delta))
|
||||
|
@ -603,7 +603,7 @@
|
|||
(play-sound-sequence 270318)
|
||||
((update-piece g pos (v+ pos (vector 0 -1)) jump-vel) s)))
|
||||
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(? patch? p)
|
||||
(sequence-transitions (transition s '())
|
||||
|
@ -679,7 +679,7 @@
|
|||
(patch-seq (retract (impulse player-id ?))
|
||||
(assert (impulse player-id (vector h-impulse 0)))))))
|
||||
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(? patch? p)
|
||||
(sequence-transitions (transition s '())
|
||||
|
@ -720,7 +720,7 @@
|
|||
(match-define (vector w h) size)
|
||||
(define block-id (gensym 'ground-block))
|
||||
(define block-pict (rectangle w h "solid" color))
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[_ #f]))
|
||||
(void)
|
||||
|
@ -742,7 +742,7 @@
|
|||
(define i (icon key planetcute-scale 1/3 2/5 4/5))
|
||||
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
|
||||
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(? patch/added?) (transition s (message (outbound (level-completed))))]
|
||||
[_ #f]))
|
||||
|
@ -824,7 +824,7 @@
|
|||
(quit (list damage-actions (message (outbound (add-to-score 1))))))
|
||||
(transition s damage-actions)))
|
||||
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(? patch? p)
|
||||
(sequence-transitions (transition s '())
|
||||
|
@ -874,7 +874,7 @@
|
|||
(patch-seq (retract (outbound* 2 (scroll-offset ?)))
|
||||
(assert (outbound* 2 (scroll-offset offset-pos))))))))))
|
||||
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(? patch? p)
|
||||
(sequence-transitions (transition s '())
|
||||
|
@ -893,7 +893,7 @@
|
|||
;; kills the dataspace.
|
||||
|
||||
(define (spawn-level-termination-monitor)
|
||||
(actor (lambda (e s)
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(? patch/removed?)
|
||||
(log-info "Player died! Terminating level.")
|
||||
|
@ -914,7 +914,7 @@
|
|||
;; LevelSpawner
|
||||
|
||||
(define (spawn-standalone-assertions . patches)
|
||||
(actor (lambda (e s) #f)
|
||||
(spawn (lambda (e s) #f)
|
||||
(void)
|
||||
patches))
|
||||
|
||||
|
@ -942,7 +942,7 @@
|
|||
#:level-size [level-size-vec (vector 4000 2000)]
|
||||
#:scene [scene grassland-backdrop]
|
||||
. actions)
|
||||
(dataspace-actor
|
||||
(spawn-dataspace
|
||||
(and scene (spawn-background-image level-size-vec scene))
|
||||
(spawn-display-controller level-size-vec)
|
||||
(spawn-physics-engine)
|
||||
|
@ -1005,7 +1005,7 @@
|
|||
(define (spawn-level-spawner starting-level)
|
||||
(struct level-spawner-state (current-level level-complete?) #:prefab)
|
||||
|
||||
(list (actor (lambda (e s)
|
||||
(list (spawn (lambda (e s)
|
||||
(match-define (level-spawner-state current-level level-complete?) s)
|
||||
(match e
|
||||
[(? patch/removed?)
|
||||
|
@ -1045,5 +1045,5 @@
|
|||
((2d-dataspace #:width 600 #:height 400)
|
||||
(spawn-keyboard-integrator)
|
||||
(spawn-scene-manager)
|
||||
(dataspace-actor (spawn-score-keeper)
|
||||
(spawn-dataspace (spawn-score-keeper)
|
||||
(spawn-level-spawner 0)))
|
||||
|
|
|
@ -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.
|
|
@ -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>
|
Before Width: | Height: | Size: 2.2 KiB |
|
@ -1 +0,0 @@
|
|||
"use strict";!function(t,r){var n=function(t){function r(t){return t.replace(/&/g,"&").replace(/</g,"<").replace(/>/g,">")}function n(t){return t.replace(/"/g,""")}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);
|
File diff suppressed because one or more lines are too long
Binary file not shown.
Before Width: | Height: | Size: 417 B |
|
@ -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>
|
Before Width: | Height: | Size: 2.7 KiB |
Binary file not shown.
Before Width: | Height: | Size: 500 B |
|
@ -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>
|
Before Width: | Height: | Size: 2.7 KiB |
|
@ -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;
|
||||
}
|
|
@ -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>
|
|
@ -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>
|
|
@ -1,2 +0,0 @@
|
|||
<li>{{issuer}} {{grantee}} {{permission}} {{isDelegable}}
|
||||
<button class="revoke">Revoke</button></li>
|
|
@ -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>
|
|
@ -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>
|
|
@ -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>
|
|
@ -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>
|
|
@ -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">×</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}}
|
|
@ -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>
|
|
@ -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>
|
|
@ -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>
|
|
@ -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>
|
|
@ -1,2 +0,0 @@
|
|||
<li>{{issuer}} {{permission}} {{isDelegable}}
|
||||
{{#isRelinquishable}}<button class="relinquish">Relinquish</button>{{/isRelinquishable}}</li>
|
|
@ -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>
|
|
@ -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 +0,0 @@
|
|||
<li>q {{issuer}} {{permissionJSON}} <a href="" class="btn btn-sm btn-secondary cancel">Cancel</a></li>
|
|
@ -1 +0,0 @@
|
|||
<li>Request to follow {{issuer}} <a href="" class="btn btn-sm btn-secondary cancel">Cancel</a></li>
|
|
@ -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>
|
|
@ -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 +0,0 @@
|
|||
<img class="post-item-image" src="{{itemURL}}">
|
|
@ -1 +0,0 @@
|
|||
<p>{{item.data}}</p>
|
|
@ -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>
|
|
@ -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);
|
||||
}
|
|
@ -1,2 +0,0 @@
|
|||
testing.rktd
|
||||
compiled/main_rkt.*
|
|
@ -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.
|
|
@ -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))))))
|
|
@ -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))))))
|
|
@ -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))])))
|
|
@ -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)])))))))
|
|
@ -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)))])))))))
|
|
@ -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)
|
|
@ -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")
|
|
@ -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
|
|
@ -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)
|
|
@ -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)
|
||||
|
|
@ -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
|
|
@ -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))))
|
|
@ -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 ...])]))]))
|
|
@ -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))))))
|
|
@ -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")
|
|
@ -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" ""))))))
|
|
@ -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)))
|
|
@ -39,6 +39,8 @@ route ('<' : nc : s) (Br (os, w, _)) f =
|
|||
Nothing -> route s (makeTail n w) f
|
||||
route (x : s) (Br (_, w, h)) f = route s (Map.findWithDefault w x h) f
|
||||
|
||||
get w h x = Map.findWithDefault w x h
|
||||
|
||||
combine f leftEmpty rightEmpty r1 r2 = g r1 r2
|
||||
where g (Ok v) r2 = f (Ok v) r2
|
||||
g r1 (Ok v) = f r1 (Ok v)
|
||||
|
@ -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 o = g o1 o2 in
|
||||
if stripTail size o == Just w then acc else Map.insert size o acc
|
||||
f x acc = update x (g (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)
|
||||
|
||||
collapse (Br (os, Mt, h)) | Map.null os && Map.null h = empty
|
||||
|
|
|
@ -42,29 +42,29 @@ var forEachChild = (function () {
|
|||
return forEachChild;
|
||||
})();
|
||||
|
||||
function buildActor(nameExpOpt, block, withReact) {
|
||||
function buildActor(constructorES5, nameExpOpt, block) {
|
||||
var nameExpStr;
|
||||
if (nameExpOpt.numChildren === 1) {
|
||||
nameExpStr = ', ' + nameExpOpt.asES5;
|
||||
} else {
|
||||
nameExpStr = '';
|
||||
}
|
||||
return 'Syndicate.Actor.spawnActor(function() ' +
|
||||
(withReact ? reactWrap(block.asES5) : block.asES5) +
|
||||
nameExpStr + ');';
|
||||
return 'Syndicate.Actor.spawnActor(new '+constructorES5+', '+
|
||||
'function() ' + block.asES5 + nameExpStr + ');';
|
||||
}
|
||||
|
||||
function reactWrap(blockCode) {
|
||||
return '{ Syndicate.Actor.Facet.build(function () { ' +
|
||||
blockCode +
|
||||
' }); }';
|
||||
function buildFacet(facetBlock, transitionBlock) {
|
||||
return '(function () { ' + (facetBlock ? facetBlock.facetVarDecls : '') +
|
||||
'\nSyndicate.Actor.createFacet()' +
|
||||
(facetBlock ? facetBlock.asES5 : '') +
|
||||
(transitionBlock ? transitionBlock.asES5 : '') +
|
||||
'.completeBuild(); })();';
|
||||
}
|
||||
|
||||
function buildOnEvent(isTerminal, eventType, subscription, projection, bindings, body) {
|
||||
return 'Syndicate.Actor.Facet.current.onEvent(Syndicate.Actor.PRIORITY_NORMAL, ' + isTerminal + ', ' +
|
||||
JSON.stringify(eventType) + ', ' +
|
||||
return '\n.onEvent(' + isTerminal + ', ' + JSON.stringify(eventType) + ', ' +
|
||||
subscription + ', ' + projection +
|
||||
', (function(' + bindings.join(', ') + ') ' + body + '));';
|
||||
', (function(' + bindings.join(', ') + ') ' + body + '))';
|
||||
}
|
||||
|
||||
function buildCaseEvent(eventPattern, body) {
|
||||
|
@ -86,11 +86,11 @@ function buildCaseEvent(eventPattern, body) {
|
|||
}
|
||||
|
||||
var modifiedSourceActions = {
|
||||
ActorStatement_noReact: function(_spawnStar, _namedOpt, nameExpOpt, block) {
|
||||
return buildActor(nameExpOpt, block, false);
|
||||
ActorStatement_noConstructor: function(_actor, _namedOpt, nameExpOpt, block) {
|
||||
return buildActor('Object()', nameExpOpt, block);
|
||||
},
|
||||
ActorStatement_withReact: function(_spawn, _namedOpt, nameExpOpt, block) {
|
||||
return buildActor(nameExpOpt, block, true);
|
||||
ActorStatement_withConstructor: function(_actor, ctorExp, _namedOpt, nameExpOpt, block) {
|
||||
return buildActor(ctorExp.asES5, nameExpOpt, block);
|
||||
},
|
||||
|
||||
DataspaceStatement_ground: function(_ground, _dataspace, maybeId, block) {
|
||||
|
@ -105,8 +105,14 @@ var modifiedSourceActions = {
|
|||
return 'Syndicate.Dataspace.spawn(new Dataspace(function () ' + block.asES5 + '));';
|
||||
},
|
||||
|
||||
ActorFacetStatement: function(_react, block) {
|
||||
return '(function () ' + reactWrap(block.asES5) + ').call(this);';
|
||||
ActorFacetStatement_state: function(_state, facetBlock, _until, transitionBlock) {
|
||||
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,
|
||||
|
@ -127,39 +133,28 @@ var modifiedSourceActions = {
|
|||
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) {
|
||||
return 'Syndicate.Dataspace.send(' + expr.asES5 + ')' + sc.interval.contents;
|
||||
},
|
||||
|
||||
ActorEndpointStatement_start: function (_on, _start, block) {
|
||||
return 'Syndicate.Actor.Facet.current.addInitBlock((function() ' + block.asES5 + '));';
|
||||
FacetBlock: function(_leftParen, _varStmts, init, situations, done, _rightParen) {
|
||||
return (init ? init.asES5 : '') + situations.asES5.join('') + (done ? done.asES5 : '');
|
||||
},
|
||||
ActorEndpointStatement_stop: function (_on, _stop, block) {
|
||||
return 'Syndicate.Actor.Facet.current.addDoneBlock((function() ' + block.asES5 + '));';
|
||||
FacetStateTransitionBlock: function(_leftParen, transitions, _rightParen) {
|
||||
return transitions.asES5.join('');
|
||||
},
|
||||
ActorEndpointStatement_assert: function(_assert, expr, whenClause, _sc) {
|
||||
return 'Syndicate.Actor.Facet.current.addAssertion(' +
|
||||
buildSubscription([expr], 'assert', 'pattern', whenClause, null) + ');';
|
||||
|
||||
FacetInitBlock: function(_init, block) {
|
||||
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,
|
||||
eventPattern.eventType,
|
||||
eventPattern.subscription,
|
||||
|
@ -167,84 +162,49 @@ var modifiedSourceActions = {
|
|||
eventPattern.bindings,
|
||||
block.asES5);
|
||||
},
|
||||
ActorEndpointStatement_onEvent: function (_on, _event, id, block) {
|
||||
return 'Syndicate.Actor.Facet.current.addOnEventHandler((function(' + id.asES5 + ') ' +
|
||||
block.asES5 + '));';
|
||||
FacetSituation_onEvent: function (_on, _event, id, block) {
|
||||
return '\n.addOnEventHandler((function(' + id.asES5 + ') ' + block.asES5 + '))';
|
||||
},
|
||||
ActorEndpointStatement_stopOnWithCont: function(_stop, _on, eventPattern, block) {
|
||||
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) {
|
||||
FacetSituation_during: function(_during, pattern, facetBlock) {
|
||||
var cachedAssertionVar = gensym('cachedAssertion');
|
||||
return buildOnEvent(false,
|
||||
'asserted',
|
||||
pattern.subscription,
|
||||
pattern.projection,
|
||||
pattern.bindings,
|
||||
'{\n' +
|
||||
'var '+cachedAssertionVar+' = '+pattern.instantiatedAssertion+';\n'+
|
||||
reactWrap(block.asES5 + '\n' +
|
||||
buildOnEvent(true,
|
||||
'retracted',
|
||||
pattern.instantiatedSubscription(cachedAssertionVar),
|
||||
pattern.instantiatedProjection(cachedAssertionVar),
|
||||
[],
|
||||
'{}')) + '}');
|
||||
},
|
||||
ActorEndpointStatement_duringSpawn: function(_during, pattern, _spawn, _named, nameExpOpt, block)
|
||||
{
|
||||
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) + ' }');
|
||||
'{ ' + facetBlock.facetVarDecls +
|
||||
'\nvar '+cachedAssertionVar+' = '+pattern.instantiatedAssertion+';'+
|
||||
'\nSyndicate.Actor.createFacet()' +
|
||||
facetBlock.asES5 +
|
||||
buildOnEvent(true,
|
||||
'retracted',
|
||||
pattern.instantiatedSubscription(cachedAssertionVar),
|
||||
pattern.instantiatedProjection(cachedAssertionVar),
|
||||
[],
|
||||
'{}') +
|
||||
'.completeBuild(); }');
|
||||
},
|
||||
|
||||
AssertWhenClause: function(_when, _lparen, expr, _rparen) {
|
||||
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.addAttribute('memberObjectExpr', {
|
||||
MemberExpression_propRefExp: function(objExpr, _dot, id) {
|
||||
return objExpr;
|
||||
},
|
||||
MemberExpression_arrayRefExp: function(objExpr, _lbrack, propExpr, _rbrack) {
|
||||
return objExpr;
|
||||
semantics.addAttribute('facetVarDecls', {
|
||||
FacetBlock: function (_leftParen, varDecls, _init, _situations, _done, _rightParen) {
|
||||
return varDecls.asES5.join(' ');
|
||||
}
|
||||
});
|
||||
|
||||
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', {
|
||||
FormalParameterList: function(formals) {
|
||||
return formals.asIteration().asSyndicateStructureArguments;
|
||||
|
@ -309,7 +269,7 @@ semantics.addAttribute('instantiatedAssertion', {
|
|||
var fragments = [];
|
||||
fragments.push('(function() { var _ = Syndicate.__; return ');
|
||||
children.forEach(function (c) { fragments.push(c.buildSubscription('instantiated')); });
|
||||
fragments.push('; }).call(this)');
|
||||
fragments.push('; })()');
|
||||
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) {
|
||||
var i = this.interval.contents;
|
||||
if (i[0] === '$' && i.length > 1) {
|
||||
|
@ -412,7 +366,7 @@ semantics.addOperation('buildSubscription(mode)', {
|
|||
return ES5.translateNonterminalCode(children,
|
||||
function(n) {
|
||||
return n.buildSubscription(self.args.mode);
|
||||
}) || this.interval.contents;
|
||||
});
|
||||
}
|
||||
});
|
||||
|
||||
|
|
|
@ -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); }
|
||||
}
|
||||
}
|
||||
}
|
|
@ -6,31 +6,38 @@ assertion type account(balance);
|
|||
message type deposit(amount);
|
||||
|
||||
ground dataspace {
|
||||
spawn {
|
||||
field this.balance = 0;
|
||||
assert account(this.balance);
|
||||
dataflow {
|
||||
console.log("Balance inside account is", this.balance);
|
||||
}
|
||||
on message deposit($amount) {
|
||||
this.balance += amount;
|
||||
actor {
|
||||
this.balance = 0;
|
||||
|
||||
react {
|
||||
assert account(this.balance);
|
||||
on message deposit($amount) {
|
||||
this.balance += amount;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
spawn {
|
||||
on asserted account($balance) {
|
||||
console.log("Balance is now", balance);
|
||||
actor {
|
||||
react {
|
||||
on asserted account($balance) {
|
||||
console.log("Balance is now", balance);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
spawn {
|
||||
on start {
|
||||
console.log("Waiting for account.");
|
||||
}
|
||||
stop on asserted Syndicate.observe(deposit(_)) {
|
||||
console.log("Account became ready.");
|
||||
:: deposit(+100);
|
||||
:: deposit(-30);
|
||||
actor {
|
||||
react {
|
||||
do {
|
||||
console.log("Waiting for account.");
|
||||
}
|
||||
finally {
|
||||
console.log("Account became ready.");
|
||||
}
|
||||
} until {
|
||||
case asserted Syndicate.observe(deposit(_)) {
|
||||
:: deposit(+100);
|
||||
:: deposit(-30);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
@ -19,20 +19,21 @@ var Dataspace = Syndicate.Dataspace;
|
|||
assertion type foo(x, y);
|
||||
|
||||
ground dataspace {
|
||||
spawn {
|
||||
field this.x = 123;
|
||||
actor {
|
||||
var x = 123;
|
||||
react {
|
||||
assert foo(x, 999);
|
||||
|
||||
assert foo(this.x, 999);
|
||||
|
||||
during foo(this.x, $v) {
|
||||
on start {
|
||||
console.log('x=', this.x, 'v=', v);
|
||||
if (this.x === 123) {
|
||||
this.x = 124;
|
||||
during foo(x, $v) {
|
||||
do {
|
||||
console.log('x=', x, 'v=', v);
|
||||
if (x === 123) {
|
||||
x = 124;
|
||||
}
|
||||
}
|
||||
finally {
|
||||
console.log('finally for x=', x, 'v=', v);
|
||||
}
|
||||
}
|
||||
on stop {
|
||||
console.log('finally for x=', this.x, 'v=', v);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
@ -1,17 +1,5 @@
|
|||
// 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');
|
||||
|
||||
assertion type file(name, content) = "file";
|
||||
|
@ -22,49 +10,55 @@ ground dataspace {
|
|||
///////////////////////////////////////////////////////////////////////////
|
||||
// The file system actor
|
||||
|
||||
spawn {
|
||||
actor {
|
||||
this.files = {};
|
||||
during Syndicate.observe(file($name, _)) {
|
||||
on start {
|
||||
console.log("At least one reader exists for:", name);
|
||||
react {
|
||||
during Syndicate.observe(file($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 stop {
|
||||
console.log("No remaining readers exist for:", name);
|
||||
on message saveFile($name, $newcontent) {
|
||||
this.files[name] = newcontent;
|
||||
}
|
||||
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
|
||||
|
||||
spawn {
|
||||
on asserted file("hello.txt", $content) {
|
||||
console.log("hello.txt has content", JSON.stringify(content));
|
||||
actor {
|
||||
react {
|
||||
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") {
|
||||
console.log("The hello.txt file contained 'quit demo', so we will quit");
|
||||
}
|
||||
}
|
||||
|
||||
spawn {
|
||||
stop on asserted Syndicate.observe(saveFile(_, _)) {
|
||||
:: saveFile("hello.txt", "a");
|
||||
:: deleteFile("hello.txt");
|
||||
:: saveFile("hello.txt", "c");
|
||||
:: saveFile("hello.txt", "quit demo");
|
||||
:: saveFile("hello.txt", "final contents");
|
||||
spawn {
|
||||
stop on asserted file("hello.txt", $content) {
|
||||
console.log("second observer sees that hello.txt content is",
|
||||
JSON.stringify(content));
|
||||
react until {
|
||||
case asserted Syndicate.observe(saveFile(_, _)) {
|
||||
:: saveFile("hello.txt", "a");
|
||||
:: deleteFile("hello.txt");
|
||||
:: saveFile("hello.txt", "c");
|
||||
:: saveFile("hello.txt", "quit demo");
|
||||
:: saveFile("hello.txt", "final contents");
|
||||
actor {
|
||||
react until {
|
||||
case asserted file("hello.txt", $content) {
|
||||
console.log("second observer sees that hello.txt content is",
|
||||
JSON.stringify(content));
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
|
@ -14,29 +14,34 @@ assertion type ready(what);
|
|||
assertion type entry(key, val);
|
||||
|
||||
ground dataspace {
|
||||
spawn named 'listener' {
|
||||
assert ready('listener');
|
||||
on asserted entry($key, _) {
|
||||
console.log('key asserted', key);
|
||||
react {
|
||||
on asserted entry(key, $value) { console.log('binding', key, '--->', value); }
|
||||
on retracted entry(key, $value) { console.log('binding', key, '-/->', value); }
|
||||
stop on retracted entry(key, _) {
|
||||
console.log('key retracted', key);
|
||||
actor named 'listener' {
|
||||
react {
|
||||
assert ready('listener');
|
||||
on asserted entry($key, _) {
|
||||
console.log('key asserted', key);
|
||||
react {
|
||||
on asserted entry(key, $value) { console.log('binding', key, '--->', value); }
|
||||
on retracted entry(key, $value) { console.log('binding', key, '-/->', value); }
|
||||
} until {
|
||||
case retracted entry(key, _) {
|
||||
console.log('key retracted', key);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
spawn named 'other-listener' {
|
||||
assert ready('other-listener');
|
||||
during entry($key, _) {
|
||||
on start { console.log('(other-listener) key asserted', key); }
|
||||
during entry(key, $value) {
|
||||
on start { console.log('(other-listener) binding', key, '--->', value); }
|
||||
on stop { console.log('(other-listener) binding', key, '-/->', value); }
|
||||
actor named 'other-listener' {
|
||||
react {
|
||||
assert ready('other-listener');
|
||||
during entry($key, _) {
|
||||
do { console.log('(other-listener) key asserted', key); }
|
||||
during entry(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');
|
||||
react {
|
||||
assert ready('pause');
|
||||
on asserted ready('pause') {
|
||||
} until {
|
||||
case asserted ready('pause') {
|
||||
return k();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
spawn named 'driver' {
|
||||
stop on asserted ready('listener') {
|
||||
react {
|
||||
stop on asserted ready('other-listener') {
|
||||
Dataspace.stateChange(Patch.assert(entry('a', 1)));
|
||||
Dataspace.stateChange(Patch.assert(entry('a', 2)));
|
||||
Dataspace.stateChange(Patch.assert(entry('b', 3)));
|
||||
Dataspace.stateChange(Patch.assert(entry('c', 33)));
|
||||
Dataspace.stateChange(Patch.assert(entry('a', 4)));
|
||||
Dataspace.stateChange(Patch.assert(entry('a', 5)));
|
||||
pause(function () {
|
||||
Dataspace.stateChange(Patch.retract(entry('a', 2)));
|
||||
Dataspace.stateChange(Patch.retract(entry('c', 33)));
|
||||
Dataspace.stateChange(Patch.assert(entry('a', 9)));
|
||||
actor named 'driver' {
|
||||
react until {
|
||||
case asserted ready('listener') {
|
||||
react until {
|
||||
case asserted ready('other-listener') {
|
||||
Dataspace.stateChange(Patch.assert(entry('a', 1)));
|
||||
Dataspace.stateChange(Patch.assert(entry('a', 2)));
|
||||
Dataspace.stateChange(Patch.assert(entry('b', 3)));
|
||||
Dataspace.stateChange(Patch.assert(entry('c', 33)));
|
||||
Dataspace.stateChange(Patch.assert(entry('a', 4)));
|
||||
Dataspace.stateChange(Patch.assert(entry('a', 5)));
|
||||
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 () {
|
||||
console.log('done');
|
||||
Dataspace.stateChange(Patch.retract(entry('a', __)));
|
||||
pause(function () {
|
||||
console.log('done');
|
||||
});
|
||||
});
|
||||
});
|
||||
});
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
@ -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
Loading…
Reference in New Issue