2017-08-10 19:17:28 +00:00
|
|
|
#lang syndicate
|
2016-11-30 05:08:35 +00:00
|
|
|
|
|
|
|
(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)
|
2017-01-06 19:51:03 +00:00
|
|
|
(require/activate syndicate/supervise)
|
2016-11-30 05:08:35 +00:00
|
|
|
(require/activate syndicate/drivers/config)
|
|
|
|
(require/activate syndicate/drivers/smtp)
|
|
|
|
(require/activate syndicate/drivers/timestate)
|
|
|
|
(require/activate syndicate/drivers/web)
|
|
|
|
|
|
|
|
(require "protocol.rkt")
|
2017-01-06 19:51:03 +00:00
|
|
|
(require "duplicate.rkt")
|
2016-11-30 05:08:35 +00:00
|
|
|
(require "session-cookie.rkt")
|
|
|
|
|
|
|
|
(define (page #:head [extra-head '()]
|
|
|
|
#:body-id [body-id #f]
|
2016-12-06 05:05:15 +00:00
|
|
|
;; #:nav-heading [nav-heading `(a ((href "/#/conversations")) "Syndicate Webchat")]
|
2016-11-30 05:08:35 +00:00
|
|
|
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")))
|
2016-12-06 02:04:41 +00:00
|
|
|
(meta ((name "format-detection") (content "email=no"))) ;; TODO: Mobile chrome seems to autolink email addresses ?!?!
|
2016-11-30 05:08:35 +00:00
|
|
|
(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")))
|
2016-12-04 05:29:06 +00:00
|
|
|
(script ((src "https://cdnjs.cloudflare.com/ajax/libs/blueimp-md5/2.6.0/js/md5.min.js")
|
|
|
|
(integrity "sha256-I0CACboBQ1ky299/4LVi2tzEhCOfx1e7LbCcFhn7M8Y=")
|
|
|
|
(crossorigin "anonymous")))
|
2016-12-06 21:06:32 +00:00
|
|
|
(script ((src "https://cdnjs.cloudflare.com/ajax/libs/immutable/3.8.1/immutable.min.js")
|
|
|
|
(integrity "sha256-13JFytp+tj8jsxr6GQOVLCgcYfMUo2Paw4jVrnXLUPE=")
|
|
|
|
(crossorigin "anonymous")))
|
2016-12-06 02:04:41 +00:00
|
|
|
(script ((src "/linkify.min.js")))
|
|
|
|
(script ((src "/linkify-string.min.js")))
|
2016-11-30 05:08:35 +00:00
|
|
|
;; (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))
|
|
|
|
`()))
|
2016-12-07 06:19:32 +00:00
|
|
|
(div ((class "container main-container"))
|
2016-11-30 05:08:35 +00:00
|
|
|
(div ((class "header clearfix"))
|
2016-12-13 21:36:35 +00:00
|
|
|
(nav ((class "navbar"))
|
2016-12-06 05:05:15 +00:00
|
|
|
;; (span ((id "nav-heading") (class "navbar-brand text-muted")) ,nav-heading)
|
2016-12-06 02:04:41 +00:00
|
|
|
(ul ((id "nav-ul") (class "nav navbar-nav nav-pills float-xs-right"))
|
2016-11-30 05:08:35 +00:00
|
|
|
;; (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"))
|
2016-12-06 02:04:41 +00:00
|
|
|
)))
|
2016-11-30 05:08:35 +00:00
|
|
|
|
|
|
|
(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))))))
|
|
|
|
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'index-page
|
2016-11-30 05:08:35 +00:00
|
|
|
(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)]))
|
|
|
|
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'logout-page
|
2016-11-30 05:08:35 +00:00
|
|
|
(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)]))
|
|
|
|
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'login-page
|
2016-11-30 05:08:35 +00:00
|
|
|
(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)
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name (list 'login-link email sid)
|
2016-11-30 05:08:35 +00:00
|
|
|
(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)))
|
2017-01-05 01:57:26 +00:00
|
|
|
(stop-when (message (delete-resource (account email))))
|
2017-02-21 20:01:46 +00:00
|
|
|
(stop-when-timeout (* (* 24 3600) 1000)))) ;; 24h = 1 day
|
2016-11-30 05:08:35 +00:00
|
|
|
|
|
|
|
(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."))))))
|
|
|
|
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'login-link-page
|
2016-11-30 05:08:35 +00:00
|
|
|
(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
|
2017-01-06 19:51:03 +00:00
|
|
|
(send! (create-resource (session email sid)))
|
2016-11-30 05:08:35 +00:00
|
|
|
(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") ".")))))
|
|
|
|
|
2017-01-06 19:51:03 +00:00
|
|
|
(supervise
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'session-monitor-factory
|
2017-01-06 19:51:03 +00:00
|
|
|
(stop-when-reloaded)
|
|
|
|
(on (message (create-resource ($ s (session $email $sid))))
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name (list 'session-monitor email sid)
|
2017-01-06 19:51:03 +00:00
|
|
|
(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
|