#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SHP: Hypertext Processor
;;
;; a PHP like web framework for PLT Scheme
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cookie.ss
;; abstraction over cookie object
;; yc 8/14/2009 - first version
(require scheme/contract
         mzlib/trace
         (prefix-in ws: web-server/http/cookie-parse)
         (prefix-in ws: web-server/http/cookie)
         (prefix-in ws: web-server/http/request-structs)
         (prefix-in ws: net/cookie)
         "request.ss"
         )

;; it is strange that the cookie parse & cookie generate makes 2 different types of cookies!
(define-struct cookie (name value domain path max-age comment secure?))

(define $cookies (make-parameter '())) 

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cookie extractors
(define (ws:client-cookie->cookie c)
  (make-cookie (ws:client-cookie-name c) 
               (ws:client-cookie-value c)
               #f
               #f
               #f
               #f
               #f
               ))

(define (init-cookies!)
  (map (lambda (c) 
         (let ((c (ws:client-cookie->cookie c)))
           (cons (cookie-name c) c)))
       (ws:request-cookies ($request))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cookie accessors
(define (cookie-set! name value 
                 #:domain (domain #f) 
                 #:path (path #f)
                 #:max-age (max-age #f)
                 #:comment (comment #f)
                 #:secure? (secure? #f)) 
  ($cookies (cons (cons name (make-cookie name value domain path max-age comment secure?)) 
                  ($cookies))))

(define (cookie-ref name)
  (let ((kv (assoc name ($cookies))))
    (if kv (cdr kv) #f)))

(define (cookie-del! name)
  (let ((kv (assoc name ($cookies))))
    ($cookies (if kv
                  (filter (lambda (c)
                            (not (equal? kv c)))
                          ($cookies))
                  ($cookies)))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cookie generators
(define (cookie->header c)
  (define (helper c) 
    (ws:make-header #"Set-Cookie"
                    (string->bytes/utf-8
                     (regexp-replace #px"Path=\\\"/\\\""
                                     (ws:print-cookie c)
                                     "Path=/"))))
  (helper 
   (ws:make-cookie (cookie-name c)
                   (cookie-value c)
                   #:domain (cookie-domain c)
                   #:path (cookie-path c)
                   #:max-age (cookie-max-age c)
                   #:comment (cookie-comment c)
                   #:secure? (cookie-secure? c))))

(define ($cookies->headers)
  (map (lambda (kv) 
         (cookie->header (cdr kv))) 
       ($cookies)))

(provide/contract 
 (struct cookie ((name string?)
                 (value string?)
                 (domain (or/c #f string?))
                 (path (or/c #f string?))
                 (max-age (or/c #f exact-nonnegative-integer?))
                 (comment (or/c #f string?))
                 (secure? boolean?)))
 ($cookies (parameter/c (listof (cons/c string? cookie?))))
 (init-cookies! (-> (listof (cons/c string? cookie?))))
 (cookie->header (-> cookie? ws:header?))
 ($cookies->headers (-> (listof ws:header?)))
 (cookie-set! (->* (string? string?)
                   (#:domain (or/c #f string?)
                             #:path (or/c #f string?)
                             #:max-age (or/c #f exact-nonnegative-integer?)
                             #:comment (or/c #f string?)
                             #:secure? boolean?)
                   any))
 (cookie-ref (-> string? (or/c #f cookie?)))
 (cookie-del! (-> string? any))
 )