#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 ; for debugging
         cookied-response
         cookie-val
         )

;; 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.

;; XXX should persist SESSIONS for when server is restart
(define SESSIONS (make-hash-table 'equal))
(define SESSION_KEY_LENGTH 20) ; totally made up

(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))

;; 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 ()
    ((_ 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
                                              ;; XXX don't hardcode the expiration date
                                              (format "~A=~A; expires=~A; path=~A"
                                                      cookie-key-str cookie-val-str
                                                      "19-Apr-2008 12:00:00 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))))
         cookie-strs)))