#lang scheme/base
(require (planet "web.scm" ("soegaard" "web.plt" 2 1))
"web-support.scm"
(file "util.scm")
(lib "time.ss" "srfi" "19"))
(provide session-put-val!
session-get-val
session-remove-entry!
sessioned-response
all-sessions cookied-response
cookie-val
)
(define SESSIONS (make-hash))
(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)))
(hash-set! SESSIONS key ht)
(values key ht)))
(define (get-session-object session-key)
(hash-ref SESSIONS session-key #f))
(define (session-put-val! sesh key val)
(hash-set! sesh key val)
sesh)
(define (session-get-val sesh key)
(hash-ref sesh key #f))
(define (session-remove-entry! sesh key)
(hash-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
#:expire-in (expire-in 2592000) . 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
(cookie-expiry-time expire-in)
"/"))))))
(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"))
(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)))