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

Hacking

This commit is contained in:
Tony Garnock-Jones 2016-12-06 15:04:41 +13:00
parent c019a61c18
commit cbdc19fc8e
24 changed files with 538 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,20 +2,57 @@ template {
display: none !important;
}
span#request-count {
background: red;
color: white;
padding: 0em 0.25em;
border-radius: 4px;
}
span#request-count.count0 {
display: none;
}
span#request-count-plural.count1 {
display: none;
}
img.avatar {
border-radius: 24px;
}
/* --------------------------------------------------------------------------- */
.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;
}

24
examples/webchat/htdocs/templates/contact-entry.html Normal file
View File

@ -0,0 +1,24 @@
<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>
{{#isPresent}}<span>(online)</span>{{/isPresent}}
</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>
<!-- <button class="dropdown-item">Follows you</button> -->
<!-- <button class="dropdown-item">Cancel pending follow request</button> -->
<!-- <button class="dropdown-item"><i class="dropdown-marginal icon ion-person-add"></i>Follow this person</button> -->
<!-- <div class="dropdown-divider"></div> -->
<!-- <button class="dropdown-item"><i class="dropdown-marginal icon ion-trash-b"></i>Delete contact</button> -->
</div>
</div>

100
examples/webchat/htdocs/templates/mainpage.html
View File

@ -1,55 +1,79 @@
<ul id="main-tabs-tabs" class="nav nav-tabs">
<li class="nav-item">
<a id="main-tab-tab-contacts" class="nav-link" href="#/contacts">Contacts</a>
</li>
<li class="nav-item">
<a id="main-tab-tab-conversations" class="nav-link" href="#/conversations"><i class="icon ion-home"></i> Conversations</a>
</li>
<li class="nav-item">
<a id="main-tab-tab-permissions" class="nav-link" href="#/permissions">Permissions</a>
</li>
<li class="nav-item">
<a id="main-tab-tab-requests" class="nav-link" href="#/requests">
<span id="request-count" class="request-count-sensitive"></span>
Request<span id="request-count-plural" class="request-count-sensitive">s</span></a>
</li>
</ul>
<div id="main-tabs-bodies">
<div id="main-tab-body-contacts">
<h3>My status</h3>
<p>
<label for="invisible">Invisible?</label>
<input type="checkbox" id="invisible">
</p>
<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">
<label for="reciprocate">Automatically allow them to follow you? </label>
<input class="form-control" id="reciprocate" type="checkbox" checked>
<button class="btn btn-default" id="add-contact">Add contact</button>
</form>
<h3>Add a new contact</h3>
<span>
<label for="add-contact-email">New contact email:</label>
<input id="add-contact-email" type="email">
<button id="add-contact">Add contact</button>
</span>
<h2>Contact List</h2>
<div class="container">
<div class="contact-list" class="row"></div>
</div>
</div>
<h3>Who is online?</h3>
<ul id="present-entries"></ul>
<div id="main-tab-body-new-chat">
<h2>New Conversation</h2>
<div class="container">
<div class="contact-list" class="row"></div>
</div>
</div>
<div id="main-tab-body-conversations">
<div class="container">
<div class="row">
<div class="col-xs-4">
<div id="conversation-list">
</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>
<div class="col-xs-8">
<p class="align-center">
Select a conversation from the column to the left,
or <a href="#/new-chat">create a new conversation</a>.
</p>
</div>
</div>
</div>
</div>
<div id="main-tab-body-permissions">
<h3>Permissions I enjoy</h3>
<h2>Permissions I enjoy</h2>
<ul id="permissions"></ul>
<h3>Permissions I have granted to others</h3>
<h2>Permissions I have granted to others</h2>
<ul id="grants"></ul>
</div>
<div id="main-tab-body-requests">
<h3>Requests I have made</h3>
<ul id="my-permission-requests"></ul>
<h3>Requests from others</h3>
<ul id="others-permission-requests"></ul>
<div id="main-tab-body-questions">
<h2>Questions</h2>
<p class="show-only-zero-count count{{questionCount}}">There are no questions waiting for you to answer.</p>
<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">
</p>
<div id="all-requests-from-others-div">
<h2>All requests from others</h2>
<ul id="others-permission-requests"></ul>
</div>
</div>
</div>
<div id="main-tab-body-my-requests">
<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>
</div>
<hr>
<!-- <pre id="debug-space"></pre> -->
</div>

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

@ -1,2 +0,0 @@
<li>{{issuer}} {{permission}}
<button class="cancel">Cancel</button></li>

20
examples/webchat/htdocs/templates/nav-account.html Normal file
View File

@ -0,0 +1,20 @@
<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" area-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="#/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>
</li>

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

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

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

@ -1,3 +0,0 @@
<li>{{issuer}} {{grantee}} {{permission}}
<button class="grant">Grant</button>
<button class="deny">Deny</button></li>

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

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

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

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

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

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

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

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

1
examples/webchat/htdocs/templates/present-entry.html
View File

@ -1 +0,0 @@
<li><img class="avatar" src="{{avatar}}"> {{email}}</li>

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

@ -4,7 +4,9 @@
// 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";
@ -17,6 +19,16 @@
// 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";
var brokerConnected = Syndicate.Broker.brokerConnected;
var brokerConnection = Syndicate.Broker.brokerConnection;
var toBroker = Syndicate.Broker.toBroker;
@ -44,6 +56,10 @@
return fromBroker(brokerUrl, x);
}
function avatar(email) {
return 'https://www.gravatar.com/avatar/' + md5(email.trim().toLowerCase()) + '?s=48&d=retro';
}
///////////////////////////////////////////////////////////////////////////
window.addEventListener('load', function () {
@ -73,6 +89,11 @@
actor {
this.ui = new Syndicate.UI.Anchor();
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;
assert brokerConnection(brokerUrl);
@ -81,7 +102,19 @@
var mainpage_c = this.ui.context('mainpage');
during inbound(uiTemplate("mainpage.html", $mainpage)) {
assert mainpage_c.html('div#main-div', mainpage);
assert mainpage_c.html('div#main-div', Mustache.render(
mainpage,
{
questionCount: this.questionCount,
myRequestCount: this.myRequestCount,
otherRequestCount: this.otherRequestCount,
globallyVisible: this.globallyVisible
}));
}
during inbound(online()) {
on start { this.globallyVisible = true; }
on stop { this.globallyVisible = false; }
}
during mainpage_c.fragmentVersion($mainpageVersion) {
@ -89,12 +122,6 @@
// of nested widgetry. If we didn't include mainpageVersion in each subwidget's
// context, then so long as the subwidget's content itself remained unchanged,
// the user would see the subwidget disappear when mainpage.html changed.
on start { console.log('mainpage up', mainpageVersion); }
on stop { console.log('mainpage down', mainpageVersion); }
during inputValue('#invisible', false) {
assert outbound(online());
}
on asserted Syndicate.UI.locationHash($hash) {
var tab = hash.substr(1);
@ -105,30 +132,69 @@
$('#main-tab-tab-' + tab).addClass('active');
}
during inbound(uiTemplate("present-entry.html", $presentEntry)) {
during inbound(present($who)) {
var c = this.ui.context(mainpageVersion, 'present', who);
assert c.html('#present-entries', Mustache.render(
presentEntry,
{
email: who,
avatar: 'https://www.gravatar.com/avatar/' + md5(who.trim().toLowerCase()) + '?s=48&d=retro'
}));
during inbound(uiTemplate("nav-account.html", $entry)) {
var c = this.ui.context(mainpageVersion, '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 inbound(uiTemplate("contact-entry.html", $entry)) {
during Syndicate.UI.locationHash('/contacts') {
during inbound(contactListEntry(sessionInfo.email, $contact)) {
field this.isPresent = false;
on asserted inbound(present(contact)) { this.isPresent = true; }
on retracted inbound(present(contact)) { this.isPresent = false; }
var c = this.ui.context(mainpageVersion, 'all-contacts', contact);
assert c.html('#main-tab-body-contacts .contact-list',
Mustache.render(entry, {
email: contact,
avatar: avatar(contact),
isPresent: this.isPresent
}));
on message c.event('.do-hi', 'click', $e) {
alert(contact);
}
}
}
}
during inputValue('#add-contact-email', $contact) {
on message mainpage_c.event('#add-contact', 'click', _) {
:: outbound(createResource(permissionRequest(contact,
sessionInfo.email,
pFollow(contact))));
// :: outbound(createResource(permissionRequest(contact,
// sessionInfo.email,
// pInvite(contact))));
// :: outbound(createResource(permissionRequest(contact,
// sessionInfo.email,
// pSeePresence(contact))));
$('#add-contact-email').val('');
during inputValue('#reciprocate', $reciprocate) {
on message mainpage_c.event('#add-contact', 'click', _) {
if (reciprocate) {
:: outbound(createResource(grant(sessionInfo.email,
sessionInfo.email,
contact,
pFollow(sessionInfo.email),
false)));
}
:: outbound(createResource(contactListEntry(sessionInfo.email, contact)));
:: outbound(createResource(permissionRequest(contact,
sessionInfo.email,
pFollow(contact))));
// :: outbound(createResource(permissionRequest(contact,
// sessionInfo.email,
// pInvite(contact))));
// :: outbound(createResource(permissionRequest(contact,
// sessionInfo.email,
// pSeePresence(contact))));
$('#add-contact-email').val('');
}
}
}
@ -162,37 +228,57 @@
}
}
during inbound(uiTemplate("my-permission-request.html", $entry)) {
during inbound(uiTemplate("permission-request-out-GENERIC.html", $genericEntry)) {
during inbound(permissionRequest($issuer, sessionInfo.email, $permission)) {
on start { this.myRequestCount++; }
on stop { this.myRequestCount--; }
var c = this.ui.context(mainpageVersion, 'my-permission-request', issuer, permission);
field this.entry = genericEntry;
assert c.html('#my-permission-requests',
Mustache.render(entry, {issuer: issuer,
permission: JSON.stringify(permission)}));
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 inbound(uiTemplate("others-permission-request.html", $entry)) {
field this.requestCount = 0;
assert mainpage_c.context(mainpageVersion, 'requestCount')
.html('#request-count', this.requestCount);
assert Syndicate.UI.uiAttribute('.request-count-sensitive',
'class',
'count' + this.requestCount);
during inputValue('#show-all-requests-from-others', $showRequestsFromOthers) {
on start {
var d = $('#all-requests-from-others-div');
if (showRequestsFromOthers) { d.show(); } else { d.hide(); }
}
}
during inbound(uiTemplate("permission-request-in-GENERIC.html", $genericEntry)) {
during inbound(permissionRequest($issuer, $grantee, $permission)) {
if (grantee !== sessionInfo.email) {
on start { this.requestCount++; }
on stop { this.requestCount--; }
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(entry, {issuer: issuer,
grantee: grantee,
permission: JSON.stringify(permission)}));
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,
@ -206,9 +292,41 @@
}
}
}
during inbound(question($qid, $timestamp, $klass, sessionInfo.email, $title, $blurb, $qt))
{
on start { this.questionCount++; }
on stop { this.questionCount--; }
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;
}
}
}
}
}
}
G.dataspace.setOnStateChange(function (mux, patch) {
$("#debug-space").text(Syndicate.prettyTrie(mux.routingTable));
});
}
})();

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

@ -19,7 +19,5 @@
(on-start (log-info "Account ~s created." email))
(on-stop (log-info "Account ~s deleted." email))
(assert (account email))
(assert (issuer email (p:follow email)))
;; (assert (issuer email (p:invite email)))
;; (assert (issuer email (p:see-presence email)))
(assert (grant email email email (p:follow email) #t))
(stop-when (message (delete-account email)))))

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

@ -22,17 +22,13 @@
#:scope scope
#:hook (lambda ()
(stop-when (message (end-session sid)))
(stop-when (message (delete-account email)))))]))))
(struct online () #:prefab)
(struct present (email) #:prefab)
(supervise
(actor #:name 'reflect-presence
(stop-when-reloaded)
(during (api (session $who _) (online))
(during (permitted who $grantee (p:follow #;p:see-presence who) _)
(assert (api (session grantee _) (present who)))))))
(stop-when (message (delete-account email)))))]
[else
(web-respond/xexpr! id
#:header (web-response-header #:code 401
#:message #"Unauthorized")
`(html (body (h1 "Unauthorized")
(a ((href "/")) "Login"))))]))))
(supervise
(actor #:name 'reflect-trust
@ -43,7 +39,9 @@
(during ($ r (permission-request _ who _))
(assert (api (session who _) r)))
(during ($ g (grant _ who _ _ _))
(assert (api (session who _) g))))))
(assert (api (session who _) g)))
(during ($ c (contact-list-entry who _))
(assert (api (session who _) c))))))
(supervise
(actor #:name 'reflect-grant-requests
@ -59,6 +57,13 @@
(actor #:name 'take-trust-instructions
(stop-when-reloaded)
(on (message (api (session $owner _) (create-resource (? contact-list-entry? $e))))
(when (equal? owner (contact-list-entry-owner e))
(send! (create-resource e))))
(on (message (api (session $owner _) (delete-resource (? contact-list-entry? $e))))
(when (equal? owner (contact-list-entry-owner e))
(send! (delete-resource e))))
(on (message (api (session $grantor _) (create-resource (? grant? $g))))
(when (equal? grantor (grant-grantor g))
(send! (create-resource g))))

83
examples/webchat/server/contacts.rkt Normal file
View File

@ -0,0 +1,83 @@
#lang syndicate/actor
(require/activate syndicate/reload)
(require/activate syndicate/supervise)
(require/activate "trust.rkt")
(require/activate "qa.rkt")
(require "protocol.rkt")
(require "duplicate.rkt")
(struct online () #:prefab)
(struct present (email) #:prefab)
(supervise
(actor #:name 'reflect-contacts
(stop-when-reloaded)
(during (api (session $who _) (online))
(during (permitted who $grantee (p:follow #;p:see-presence who) _)
;; `who` allows `grantee` to follow them
(assert (api (session grantee _) (present who)))))))
(actor #:name 'contact-list-factory
(stop-when-reloaded)
(on (message (create-resource ($ e (contact-list-entry $owner $member))))
(actor #:name e
(on-start (log-info "~s adds ~s to their contact list" owner member))
(on-stop (log-info "~s removes ~s from their contact list" owner member))
(assert e)
(stop-when-duplicate e)
(stop-when (message (delete-resource e)))
(stop-when (asserted (delete-account owner)))
(stop-when (asserted (delete-account member))))))
(supervise
(actor #:name 'contacts:questions
(stop-when-reloaded)
;; TODO: NOTE: 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
(on-start
(define-values (title blurb)
(if (equal? who grantor)
(values (format "Follow 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 "Request from ~a to follow ~a" grantee who)
`(p "User " (b ,grantee) " wants to be able to invite "
(b ,who) " to conversations and see when they are online."))))
(define base-options
(list (list "deny" "Reject")
(list "ignore" "Ignore")))
(match (ask-question #:title title #:blurb blurb #:target grantor #:class "q-follow"
(option-question
;; If who == grantor, then the grantor is directly
;; the person being followed, and should be offered
;; the option to follow back, unless they've already
;; taken that option, which can be deduced if BOTH
;; the grantee has declared that the grantor may
;; follow the grantee AND the grantor has declared
;; that the grantee is a member of their contact
;; list.
(if (and (equal? who grantor)
(not (and
(immediate-query [query-value #f (permitted grantee grantor (p:follow grantee) _) #t])
(immediate-query [query-value #f (contact-list-entry grantor grantee) #t]))))
(list* (list "allow-and-return" "Accept and follow back")
(list "allow" "Accept, but do not follow back")
base-options)
(cons (list "allow" "Accept")
base-options))))
["allow-and-return"
(send! (create-resource (grant who grantor grantee p #f)))
(send! (create-resource (contact-list-entry grantor grantee)))
(send! (create-resource (permission-request grantee grantor (p:follow grantee))))]
["allow" (send! (create-resource (grant who grantor grantee p #f)))]
["deny" (send! (delete-resource (permission-request who grantee p)))]
["ignore" (void)])))))))

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

@ -1,7 +1,7 @@
#lang syndicate/actor
(provide )
(require/activate syndicate/reload)
(require/activate syndicate/supervise)
(require/activate "trust.rkt")
(require "protocol.rkt")
(actor #:name

17
examples/webchat/server/duplicate.rkt Normal file
View File

@ -0,0 +1,17 @@
#lang syndicate/actor
(provide stop-when-duplicate)
(require syndicate/protocol/instance)
(require "util.rkt")
(define (stop-when-duplicate spec)
(define id (random-hex-string 16))
(field [duplicate? #f])
(stop-when (rising-edge (duplicate?)))
(assert (instance id spec))
(on (asserted (instance $id2 spec))
(when (string<? id id2)
(log-info "Duplicate instance of ~v detected; terminating" spec)
(duplicate? #t)))
id)

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

@ -9,3 +9,6 @@
(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")

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

@ -19,12 +19,13 @@
(define (page #:head [extra-head '()]
#:body-id [body-id #f]
#:nav-heading [nav-heading "Syndicate Webchat"]
#: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")
@ -45,6 +46,8 @@
(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 "/linkify.min.js")))
(script ((src "/linkify-string.min.js")))
;; (script ((src "/syndicatecompiler.min.js")))
(script ((src "/syndicate.min.js")))
(script ((src "/webchat.js")))
@ -56,12 +59,13 @@
`()))
(div ((class "container"))
(div ((class "header clearfix"))
(nav (ul ((id "nav-ul") (class "nav nav-pills float-xs-right"))
(nav ((class "navbar bg-faded"))
(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"))
))
(h3 ((id "nav-heading") (class "text-muted")) ,nav-heading))
)))
(div ((id "main-div")))
;; (div ((class "row marketing"))
@ -143,7 +147,6 @@
id
(page (format "Webchat: ~a" email)
#:body-id "webchat-main"
#:nav-heading email
#:head (list `(meta ((itemprop "webchat-session-email") (content ,email)))
`(meta ((itemprop "webchat-session-id") (content ,sid)))))))

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

@ -2,6 +2,10 @@
(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
@ -64,9 +68,6 @@
;; TODO: Action: report a cap request as spam or some other kind of nuisance
;; (issuer Principal Any)
(struct issuer (email permission) #:prefab) ;; ASSERTION
;; (grant Principal Principal Principal Any Boolean)
;; Links in a grant chain.
(struct grant (issuer grantor grantee permission delegable?) #:prefab) ;; ASSERTION
@ -91,7 +92,14 @@
;; 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)
@ -130,29 +138,12 @@
;; Simple posting is a combination of draft+approve.
;; Flagging a post for moderator attention is a kind of reaction.
;; (conversation String String Principal Markdown Boolean
;; (conversation String String Principal Markup Boolean
(struct conversation (id title creator blurb) #:prefab) ;; ASSERTION
;; (delete-conversation String)
;; TODO: use resource management messages instead
(struct delete-conversation (id) #:prefab) ;; MESSAGE
;; (invitation String Principal)
(struct invitation (conversation-id invitee) #:prefab) ;; ASSERTION
;; (join-conversation String Principal)
;; Used to accept an invitation
;; TODO: use resource management messages instead
(struct join-conversation (id member) #:prefab) ;; MESSAGE
;; (leave-conversation String Principal)
;; Used to - cancel open invitations (by issuer)
;; - reject open invitations (by invitee)
;; - eject a member from a conversation (by a moderator)
;; - leave a conversation (by a member)
;; TODO: use resource management messages instead
(struct leave-conversation (id member) #:prefab) ;; MESSAGE
;; (in-conversation String Principal)
;; Records conversation membership.
(struct in-conversation (conversation-id member) #:prefab) ;; ASSERTION
@ -171,16 +162,17 @@
;; A fragment of HTML for use in the web client.
(struct ui-template (name data) #:prefab) ;; ASSERTION
;; (question String String Principal String Markdown QuestionType)
(struct question (id class target title blurb type) #: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 Markdown Markdown)
;; - (option-question (Listof (Cons Any Markdown)))
;; - (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)

43
examples/webchat/server/qa.rkt Normal file
View File

@ -0,0 +1,43 @@
#lang syndicate/actor
(provide ask-question)
(require racket/port)
(require markdown)
(require/activate syndicate/reload)
(require/activate syndicate/supervise)
(require "protocol.rkt")
(require "util.rkt")
(supervise
(actor #: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))
(react/suspend (k)
(assert q)
(stop-when (asserted (answer qid $v))
(k v))))

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

@ -33,6 +33,7 @@
(define url->path (make-url->path templates-path))
(during (api _ (observe (ui-template $name _)))
(define-values (path path-pieces) (url->path (string->url name)))
(log-info "Observation of ~v" path)
(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))))))

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

@ -1,33 +1,20 @@
#lang syndicate/actor
(require racket/set)
(require syndicate/protocol/instance)
(require/activate syndicate/reload)
(require "protocol.rkt")
(require "util.rkt")
(require "duplicate.rkt")
(actor #:name 'trust-inference
(stop-when-reloaded)
(during (issuer $who $permission)
(assert (permitted who who permission #t)))
(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?)))))
(define (stop-when-duplicate spec)
(define id (random-hex-string 16))
(field [duplicate? #f])
(stop-when (rising-edge (duplicate?)))
(assert (instance id spec))
(on (asserted (instance $id2 spec))
(when (string<? id id2)
(log-info "Duplicate instance of ~v detected; terminating" spec)
(duplicate? #t)))
id)
(actor #:name 'grant-factory
(stop-when-reloaded)
(on (message (create-resource
@ -42,6 +29,7 @@
(stop-when (message (delete-resource g)))
(stop-when (message
(delete-resource (permitted issuer grantee permission delegable?))))
(stop-when (message (delete-account issuer)))
(stop-when (message (delete-account grantor)))
(stop-when (message (delete-account grantee))))))
@ -55,13 +43,9 @@
(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 (issuer grantee permission))
(log-info "~s's request of ~s from ~s is axiomatically granted"
grantee permission the-issuer))
(stop-when (asserted (grant the-issuer $grantor grantee permission $delegable?))
(log-info "~s's request of ~s from ~s was approved~a by ~s"
(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," "")
grantor)))))
(if delegable? ", delegably," ""))))))