;;; cookie.scm  --  Jens Axel Søgaard  --  17th feb 2006

; This module provides

;   - make-cookie       to create cookies
;   - request-cookies   to extract cookies from a request
;   - cookie-value      to extract a value stored in a cookie
;   - cookie-values     to extract values stored in a cookie
;   - output-cookie     to add a cookie to current-output-cookies

; furthermore two parameters are provied

;   - current-cookies          holds the cookies received in the current request
;   - current-output-cookies   holds the cookies which will be sent out in the
;                              response to the current request

; The current-cookies parameter is to be set in the servlet's start functions.
; The list of cookies in current-output-cookies is to be included in
; in the response returned from the servler's start function.

; EXAMPLE
;    (make-cookie "time" (number->string (current-seconds)) #:max-age 3600)
;    (make-cookie "id" "soegaard")


(module cookie mzscheme
  (provide make-cookie
           request-cookies
           cookie-value
           cookie-values
           output-cookie
           ; parameters
           current-cookies
           current-output-cookies)
  
  (require (lib "cookie.ss" "net")
           (lib "servlet.ss" "web-server")
           (lib "kw.ss"))
  
  (define current-cookies        (make-parameter '()))
  (define current-output-cookies (make-parameter '()))
  
  ; Note: name and val must be strings. The call to (set-cookie ...) checks that
  ;       they contain legal characters only, but be careful not to be fooled
  ;       be the error message:
  ;           "make-cookie-error: expects argument of type <immutable string>;
  ;           given "Invalid NAME/VALUE pair: time- / 1138569495"
  ;      Here the culprit is the illegal char - (in time- )
  
  (define/kw 
    (make-cookie  name val #:key 
                  (comment #f) (domain #f) (max-age #f)
                  (path    #f) (secure #f) (version #f))
    (let* ([c (set-cookie name val)]
           [c (if comment (cookie:add-comment c comment) c)]
           [c (if domain  (cookie:add-domain  c domain)  c)]
           [c (if max-age (cookie:add-max-age c max-age) c)]
           [c (if path    (cookie:add-path    c path)    c)]
           [c (if secure  (cookie:secure      c secure)  c)]
           [c (if version (cookie:version     c version) c)])
      (print-cookie c)))
  
  ; request-cookies : request -> bindings
  (define (request-cookies request)
    (extract-bindings 'cookie (request-headers request)))
  
  ; cookie-value : string -> (union string #f)
  (define/kw (cookie-value name #:optional (on-not-found #f))
    ; return the first associated value; if none exists #f is returned
    (let ([val (get-cookie/single name (current-cookies))])
      (if val val on-not-found)))
  
  ; cookie-values : string -> (list string)
  (define (cookie-values name)
    ; return a list of associated values
    (get-cookie name (current-cookies)))
  
  (make-cookie "time" (number->string (current-seconds)) #:max-age 3600)
  (make-cookie "id" "soegaard")
  
  ; output-cookie : cookie -> #void
  ;   add cookie to current-output-cookies
  (define (output-cookie cookie)
    (current-output-cookies
     (cons cookie (current-output-cookies))))
  
  )