#lang scheme/base
(require (planet "web.scm" ("soegaard" "web.plt" 2 1))
"web-support.scm"
(file "util.scm"))
(provide session-put-val!
session-get-val
session-remove-entry!
sessioned-response
all-sessions cookied-response
cookie-val
)
(define SESSIONS (make-hash-table 'equal))
(define SESSION_KEY_LENGTH 20)
(define (all-sessions)
SESSIONS)
(define (make-fresh-session #:session-key (session-key #f))
(let ((key (or session-key (random-key-string SESSION_KEY_LENGTH)))
(ht (make-hash-table)))
(hash-table-put! SESSIONS key ht)
(values key ht)))
(define (get-session-object session-key)
(hash-table-get SESSIONS session-key #f))
(define (session-put-val! sesh key val)
(hash-table-put! sesh key val)
sesh)
(define (session-get-val sesh key)
(hash-table-get sesh key #f))
(define (session-remove-entry! sesh key)
(hash-table-remove! sesh key))
(define-syntax sessioned-response
(syntax-rules ()
((_ sesh-iden (req) => 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 ...))
`(group ,body ...))))))
(define (cookied-response cookie-key-str cookie-val-str . content-lst)
(list-response content-lst
#:extras (list (make-header #"Set-Cookie"
(string->bytes/utf-8
(format "~A=~A; expires=~A; path=~A"
cookie-key-str cookie-val-str
"19-Apr-2008 12:00:00 GMT" "/"))))))
(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))))
cookie-strs)))