Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
tag: jcRC1
Fetching contributors…

Cannot retrieve contributors at this time

135 lines (114 sloc) 4.531 kB
#lang scheme/base
(require (planet "web.scm" ("soegaard" "web.plt" 2 1))
"web-support.scm"
(file "util.scm")
(file "time.scm")
(file "record.scm")
(file "repository.scm")
(lib "time.ss" "srfi" "19"))
(provide session-put-val!
session-get-val
session-id
session-get-hash
session-replace-hash!
get-session-object
session-remove-entry!
sessioned-response
make-fresh-session
remove-session
cookied-response
cookie-val
flash-create!
flash-get!
)
;; a session is a map from keys to values
;; we store a key to a session in a client cookie with key "sesh" and the session id
;; as the value.
(define SESSION_KEY_LENGTH 20) ; totally made up
(define (make-fresh-session)
(let ((rec (fresh-rec-from-data '((type . session))
#:stamp-time #t
#:id-length SESSION_KEY_LENGTH)))
(store-rec! rec)
(values (rec-id rec) rec)))
(define (remove-session sesh)
(delete-rec! sesh))
(define (get-session-object session-key)
(and (record-id-stored? session-key)
(load-rec session-key)))
(define (session-put-val! sesh key val)
(rec-set-prop! sesh key val)
(store-rec! sesh)
sesh)
(define (session-get-hash sesh)
(rec-data sesh))
(define (session-replace-hash! sesh hash)
(rec-set-data! sesh hash)
(store-rec! sesh)
sesh)
(define (session-get-val sesh key (missing-val #f))
(rec-prop sesh key missing-val))
(define (session-id sesh)
(rec-id sesh))
(define (session-remove-entry! sesh key)
(rec-remove-prop! sesh key)
(store-rec! sesh)
sesh)
;; evaluates the body, binding sesh-iden to a sesh (either existing or fresh).
;; the latter case happens if this is their first time hitting the page from that browser,
;; if they logged out, or if they have cookies off.
(define-syntax sessioned-response
(syntax-rules ()
((_ req (sesh-iden) body ...)
(let* ((sesh-id (cookie-val req "sesh"))
(sesh-iden (and sesh-id (get-session-object sesh-id))))
(if (not sesh-iden)
(receive (fresh-sesh-id sesh-iden) (make-fresh-session)
(cookied-response "sesh" fresh-sesh-id
body ...))
(let ((body-lst (list body ...)))
(or (single-response-promise-in-list body-lst)
(single-response/full-in-list body-lst)
`(group ,@body-lst))))))))
(define (cookied-response cookie-key-str cookie-val-str
#:expire-in (expire-in THIRTY_DAYS)
. content-lst)
(let ((headers (list (make-header #"Set-Cookie"
(string->bytes/utf-8
(format "~A=~A; expires=~A; path=~A"
cookie-key-str cookie-val-str
(cookie-expiry-time expire-in)
"/"))))))
(aif (single-response-promise-in-list content-lst)
(response-from-promise it #:headers headers)
(list-response content-lst #:extras headers))))
(define (cookie-expiry-time secs-from-now)
(date->string (time-utc->date (make-time 'time-utc 0
(+ (current-seconds) secs-from-now))
0)
"~a, ~d-~b-~Y ~T GMT"))
;; returns #f if no matching key-str is found; o/w returns a str val
(define (cookie-val req key-str)
(and-let* ((header-binds (request-headers req))
((exists-binding? 'cookie header-binds))
(cookie-strs (pregexp-split "; "
(extract-binding/single 'cookie
(request-headers req)))))
(any (lambda (kv-str)
(match (pregexp-split "=" kv-str)
((list key val)
(and (string=? key-str key) val))
(else #f)))
cookie-strs)))
;;
;; flash implementation
;;
;; A flash is a some data that stays until it is used. The classic example is with
;; messages that persist to the user just one time, like "Your message was sent."
;;
(define (flash-create! sesh key val)
(session-put-val! sesh key val))
(define (flash-get! sesh key)
(let ((val (session-get-val sesh key)))
(session-remove-entry! sesh key)
val))
Jump to Line
Something went wrong with that request. Please try again.