#lang scheme/base

(require (planet "dispatch.ss" ("untyped" "dispatch.plt" 1))
         (planet "web.scm" ("soegaard" "web.plt" 2 1))
         "web-support.scm"
         "session.scm")

(provide define-page
         define-session-page
         page-url
         redirect-to-page
         make-wrapper
         atom-wrapper)

;;
;; define-page
;;
;; e.g., (define-page (foo-page req)
;;         "Hello, World!")
;; or
;;       (define-page (bar-page req)
;;         #:wrapper my-personal-wrapper
;;         "Hi again.")
;;
(define-syntax define-page
  (syntax-rules (bind)
    ((_ (page-name args ...)
        (bind (iden val) ...)
        body ...)
     (define-controller (page-name args ...)
       (let ((iden val) ...)
         (page-aux body ...))))
    ((_ (page-name args ...)
        body ...)
     (define-page (page-name args ...) (bind) body ...))))

(define-syntax define-session-page
  (syntax-rules ()
    ((_ (page-name req-iden sesh-iden args ...)
        body ...)
     (define-controller (page-name req-iden args ...)
       (sessioned-response sesh-iden (req-iden) =>
                           (page-aux body ...))))))

(define (page-aux #:wrapper (wrapper (make-wrapper)) . body)
  (apply wrapper body))

(define (js-inc script-filename)
  `(script ((src ,script-filename)) ""))

(define (css-inc css-filename)
  `(link ((rel "stylesheet") (type "text/css") (href ,css-filename))))

;; body-wrap : body ... -> content
(define (make-wrapper #:raw-header (raw-header '())
                      #:css (css '())
                      #:js (js '())
                      #:title (title "a LeftParen web app")
                      #:body-wrap (body-wrap #f))
  (lambda body
    `(html (head ,@raw-header
                 ,@(map css-inc css)
                 ,@(map js-inc js)
                 (title ,title))
           (body ,@(if body-wrap (list (apply body-wrap body)) body)))))

(define (atom-wrapper . body)
  (list-response #:type #"text/xml"
                 (list (raw-str "<?xml version=\"1.0\" encoding=\"utf-8\"?>")
                       `(feed ((xmlns "http://www.w3.org/2005/Atom"))
                              ,@body))))

(define (redirect-to-page page-name . args)
  (redirect-to (apply controller-url page-name args)))

(define page-url controller-url)