syndicate-2017/examples/webchat/server/pages.rkt

278 lines
14 KiB
Racket

#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