diff --git a/examples/webchat/htdocs/style.css b/examples/webchat/htdocs/style.css
index 1986f8d..37c4bfc 100644
--- a/examples/webchat/htdocs/style.css
+++ b/examples/webchat/htdocs/style.css
@@ -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;
+}
diff --git a/examples/webchat/htdocs/templates/contact-entry.html b/examples/webchat/htdocs/templates/contact-entry.html
new file mode 100644
index 0000000..d910656
--- /dev/null
+++ b/examples/webchat/htdocs/templates/contact-entry.html
@@ -0,0 +1,24 @@
+
-
My status
-
-
-
-
+
Add a new contact
+
-
Add a new contact
-
-
-
-
-
+
Contact List
+
+
-
Who is online?
-
+
-
Permissions I enjoy
+
Permissions I enjoy
-
Permissions I have granted to others
+
Permissions I have granted to others
-
-
Requests I have made
-
-
-
Requests from others
-
+
+
Questions
+
There are no questions waiting for you to answer.
+
+
+
+
+
+
+
+
All requests from others
+
+
+
+
+
+
Requests I have made
+
You have no outstanding requests waiting for responses from others.
+
+
+
+
+
diff --git a/examples/webchat/htdocs/templates/my-permission-request.html b/examples/webchat/htdocs/templates/my-permission-request.html
deleted file mode 100644
index 42d52c3..0000000
--- a/examples/webchat/htdocs/templates/my-permission-request.html
+++ /dev/null
@@ -1,2 +0,0 @@
-
{{issuer}} {{permission}}
-
diff --git a/examples/webchat/htdocs/templates/nav-account.html b/examples/webchat/htdocs/templates/nav-account.html
new file mode 100644
index 0000000..15e672e
--- /dev/null
+++ b/examples/webchat/htdocs/templates/nav-account.html
@@ -0,0 +1,20 @@
+
+
+
+ {{questionCount}}
+ {{email}}
+
+
diff --git a/examples/webchat/htdocs/templates/option-question.html b/examples/webchat/htdocs/templates/option-question.html
new file mode 100644
index 0000000..fa2dea4
--- /dev/null
+++ b/examples/webchat/htdocs/templates/option-question.html
@@ -0,0 +1,11 @@
+
+
+
{{title}}
+ {{&blurb}}
+
+ {{#options}}
+
+ {{/options}}
+
+
+
diff --git a/examples/webchat/htdocs/templates/others-permission-request.html b/examples/webchat/htdocs/templates/others-permission-request.html
deleted file mode 100644
index ff7d871..0000000
--- a/examples/webchat/htdocs/templates/others-permission-request.html
+++ /dev/null
@@ -1,3 +0,0 @@
-
{{issuer}} {{grantee}} {{permission}}
-
-
diff --git a/examples/webchat/htdocs/templates/permission-request-in-GENERIC.html b/examples/webchat/htdocs/templates/permission-request-in-GENERIC.html
new file mode 100644
index 0000000..d6f50ce
--- /dev/null
+++ b/examples/webchat/htdocs/templates/permission-request-in-GENERIC.html
@@ -0,0 +1,3 @@
+
{{issuer}} {{grantee}} {{permissionJSON}}
+ Grant
+ Deny
diff --git a/examples/webchat/htdocs/templates/permission-request-in-p:follow.html b/examples/webchat/htdocs/templates/permission-request-in-p:follow.html
new file mode 100644
index 0000000..af3fc8b
--- /dev/null
+++ b/examples/webchat/htdocs/templates/permission-request-in-p:follow.html
@@ -0,0 +1,3 @@
+
Request from {{grantee}} to follow {{permission.fields.0}}
+ Grant
+ Deny
diff --git a/examples/webchat/htdocs/templates/permission-request-out-GENERIC.html b/examples/webchat/htdocs/templates/permission-request-out-GENERIC.html
new file mode 100644
index 0000000..861f07b
--- /dev/null
+++ b/examples/webchat/htdocs/templates/permission-request-out-GENERIC.html
@@ -0,0 +1 @@
+
q {{issuer}} {{permissionJSON}} Cancel
diff --git a/examples/webchat/htdocs/templates/permission-request-out-p:follow.html b/examples/webchat/htdocs/templates/permission-request-out-p:follow.html
new file mode 100644
index 0000000..b0d3c23
--- /dev/null
+++ b/examples/webchat/htdocs/templates/permission-request-out-p:follow.html
@@ -0,0 +1 @@
+
Request to follow {{issuer}} Cancel
diff --git a/examples/webchat/htdocs/templates/present-entry.html b/examples/webchat/htdocs/templates/present-entry.html
deleted file mode 100644
index 9b73586..0000000
--- a/examples/webchat/htdocs/templates/present-entry.html
+++ /dev/null
@@ -1 +0,0 @@
-
{{email}}
diff --git a/examples/webchat/htdocs/webchat.syndicate.js b/examples/webchat/htdocs/webchat.syndicate.js
index ad4b371..c6d5b96 100644
--- a/examples/webchat/htdocs/webchat.syndicate.js
+++ b/examples/webchat/htdocs/webchat.syndicate.js
@@ -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));
+ });
}
})();
diff --git a/examples/webchat/server/account.rkt b/examples/webchat/server/account.rkt
index 261c617..b65ff3d 100644
--- a/examples/webchat/server/account.rkt
+++ b/examples/webchat/server/account.rkt
@@ -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)))))
diff --git a/examples/webchat/server/api.rkt b/examples/webchat/server/api.rkt
index 5084c09..c95cee1 100644
--- a/examples/webchat/server/api.rkt
+++ b/examples/webchat/server/api.rkt
@@ -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))))
diff --git a/examples/webchat/server/contacts.rkt b/examples/webchat/server/contacts.rkt
new file mode 100644
index 0000000..99328f1
--- /dev/null
+++ b/examples/webchat/server/contacts.rkt
@@ -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)])))))))
+
diff --git a/examples/webchat/server/conversation.rkt b/examples/webchat/server/conversation.rkt
index c93db19..fdc600a 100644
--- a/examples/webchat/server/conversation.rkt
+++ b/examples/webchat/server/conversation.rkt
@@ -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
diff --git a/examples/webchat/server/duplicate.rkt b/examples/webchat/server/duplicate.rkt
new file mode 100644
index 0000000..28b6a4c
--- /dev/null
+++ b/examples/webchat/server/duplicate.rkt
@@ -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)
diff --git a/examples/webchat/server/main.rkt b/examples/webchat/server/main.rkt
index fb64da0..3bdb0fe 100644
--- a/examples/webchat/server/main.rkt
+++ b/examples/webchat/server/main.rkt
@@ -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")
diff --git a/examples/webchat/server/pages.rkt b/examples/webchat/server/pages.rkt
index ab99248..ebe70a9 100644
--- a/examples/webchat/server/pages.rkt
+++ b/examples/webchat/server/pages.rkt
@@ -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)))))))
diff --git a/examples/webchat/server/protocol.rkt b/examples/webchat/server/protocol.rkt
index ad0f686..b0fab5e 100644
--- a/examples/webchat/server/protocol.rkt
+++ b/examples/webchat/server/protocol.rkt
@@ -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)
diff --git a/examples/webchat/server/qa.rkt b/examples/webchat/server/qa.rkt
new file mode 100644
index 0000000..14bd729
--- /dev/null
+++ b/examples/webchat/server/qa.rkt
@@ -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))))
+
diff --git a/examples/webchat/server/static-content.rkt b/examples/webchat/server/static-content.rkt
index ccf398b..c8b78f6 100644
--- a/examples/webchat/server/static-content.rkt
+++ b/examples/webchat/server/static-content.rkt
@@ -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))))))
diff --git a/examples/webchat/server/trust.rkt b/examples/webchat/server/trust.rkt
index 138e71e..2e8fd34 100644
--- a/examples/webchat/server/trust.rkt
+++ b/examples/webchat/server/trust.rkt
@@ -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," ""))))))