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

;; the list of http-status, code & text.  this is internal and might change
(define http-status '((continue 100 "Continue")
                      (switching-protocols 101 "Switching Protocols")
                      (ok 200 "OK")
                      (created 201 "Created")
                      (accepted 202 "Accepted")
                      (non-authoritative-information 203 "Non-Authoritative Information")
                      (no-content 204 "No Content")
                      (reset-content 205 "Reset Content")
                      (partial-content 206 "Partial Content")
                      (multiple-choices 300 "Multiple Choices")
                      (moved-permanently 201 "Moved Permanently")
                      (found 302 "Found")
                      (see-other 303 "See Other")
                      (not-modified 304 "Not Modified")
                      (use-proxy 305 "Use Proxy")
                      (temporary-redirect 307 "Temporary Redirect")
                      (bad-request 400 "Bad Request")
                      (unauthorized 401 "Unauthorized")
                      (payment-required 402 "Payment Required")
                      (forbidden 403 "Forbidden")
                      (not-found 404 "Not Found")
                      (method-not-allowed 405 "Method Not Allowed")
                      (not-acceptable 406 "Not Acceptable")
                      (proxy-authentication-required 407 "Proxy Authentication Required")
                      (request-timeout 408 "Request Timeout")
                      (conflict 409 "Conflict")
                      (gone 410 "Gone")
                      (length-required 411 "Length Required")
                      (precondition-failed 412 "Precondition Failed")
                      (request-entity-too-large 413 "Request Entity Too Large")
                      (request-uri-too-long 414 "Request-URI Too Long")
                      (unsupported-media-type 415 "Unsupported Media Type")
                      (request-range-not-satisfied 416 "Requested Range Not Satisfiable")
                      (expectation-failed 417 "Expectation Failed")
                      (internal-server-error 500 "Internal Server Error")
                      (not-implemented 501 "Not Implemented")
                      (bad-gateway 502 "Bad Gateway")
                      (service-unavailable 503 "Service Unavailable")
                      (gateway-timeout 504 "Gateway Timeout")
                      (version-not-supported 505 "HTTP Version Not Supported")))

(define $status (make-parameter 'ok))

;; for testing to see whether the stauts is valid.
(define (valid-status? status)
  (assoc status http-status))

;; convert the status into code
(define ($status->code)
  (cadr (valid-status? ($status))))

;; convert the status into text
(define ($status->text)
  (string->bytes/utf-8 (caddr (valid-status? ($status)))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; special headers.
(define $content-type (make-parameter "text/html; charset=utf-8"))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; headers
(define $headers (make-parameter '()))

(define (header! key val (replace? #t)) 
  ;; add the keyval to the headers!
  ($headers (cons (cons key val) ($headers))))

;; this function might require changes because response objects have kept changing
(define ($headers->headers)
  (map (lambda (kv)
         (make-header (string->bytes/utf-8 (car kv))
                      (string->bytes/utf-8 (cdr kv))))
       ($headers)))

(define (make-response output) 
  (cond ((xexpr? output) 
         (make-response/full ($status->code)
                             ($status->text)
                             (current-seconds)
                             (string->bytes/utf-8 ($content-type))
                             (append ($headers->headers)
                                     ($cookies->headers))
                             (list 
                              (string->bytes/utf-8
                               (xexpr->string output)))))))

(define (redirect! url 
                   #:status (status 'temporary-redirect) 
                   #:headers (headers '()))
  (define (header-helper h)
    (cond ((header? h) h)
          ((pair? h) (make-header (string->bytes/utf-8 (car h))
                                  (string->bytes/utf-8 (cdr h))))
          ((cookie? h)
           (cookie->header h))))
  (raise (redirect-to (if (url? url) (url->string url) url)
                      (case status
                        ((found) permanently)
                        ((see-other) see-other)
                        ((temporary-redirect) temporarily))
                      #:headers (map header-helper headers))))

(provide/contract 
 ($status (parameter/c valid-status?))
 ($headers (parameter/c (listof (cons/c string? string?))))
 ($content-type (parameter/c string?))
 (header! (->* (string? string?)
               (boolean?)
               any)) 
 (make-response (-> xexpr? response/c))
 (redirect! (->* ((or/c string? url?))
                 (#:status (or/c 'found 'see-other 'temporary-redirect)
                           #:headers (listof (or/c (cons/c string? string?)
                                                   header?
                                                   cookie?)))
                 any))
 )