web-page.ss
(module web-page mzscheme
  (require (planet "io.ss" ("dherman" "io.plt" 1 7))
           (lib "servlet.ss" "web-server")
           (lib "response.ss" "web-server")
           (lib "pretty.ss")
           (lib "xml.ss" "xml")
           (lib "match.ss"))

  (define (callback-url proc)
    ((current-callback->url) proc))

  (define current-callback->url
    (make-parameter (lambda (proc)
                      (error 'callback "not in a web context"))))

  (define (pretty-print-invalid-xexpr exn xexpr)
    (let ([original (pretty-print-print-hook)]
          [code (exn:invalid-xexpr-code exn)])
      (parameterize ([pretty-print-size-hook (lambda (v display? out)
                                               (and (equal? v code)
                                                    (string-length (format (if display? "~a" "~v") v))))]
                     [pretty-print-print-hook (lambda (v display? out)
                                                (fprintf out
                                                         (string-append
                                                          "<span class='erroneous'>"
                                                          (if display? "~a" "~v")
                                                          "</span>")
                                                         v))])
        (pretty-print xexpr))))

  (define default-error-handler
    (lambda (exn x)
      (make-response/full
       500 "Servlet Error"
       (current-seconds)
       #"text/html"
       '()
       (list
        (string-append
         "<html>"
         "<head>"
         "<title>Error: ill-formed page</title>"
         "<style type='text/css'>\n"
         "    .erroneous {background-color:pink;}\n"
         "    .error {font-family: sans-serif; font-style: italic; color: red; font-size: small;}\n"
         "    img {vertical-align: absbottom;}\n"
         "    a img {border-style: none;}\n"
         "</style>"
         "<script type='text/javascript'>\n"
         "function activateBug() {\n"
         "    var bug = document.all ? document.all['bug'] : document.getElementById('bug');\n"
         "    var all = document.getElementsByTagName('span');\n"
         "    if (bug && all && all.length > 0) {\n"
         "        var span = all[0];\n"
         "        if (span.scrollIntoView) {\n"
         "            bug.href = 'javascript:void(0)';\n"
         "            bug.onclick = function() { span.scrollIntoView() };\n"
         "        }\n"
         "    }\n"
         "}\n"
         "</script>"
         "</head>"
         "<body onload='activateBug()'>"
         "<h1>Error: ill-formed page</h1>"
         "<p>The source X-expression for this page was ill-formed. The server produced the following error:</p>"
         "<blockquote><p class='error'><a id='bug'><img src='http://svn.plt-scheme.org/plt/trunk/collects/icons/bug09.gif' width='27' height='28'/></a> " (exn-message exn) "</p></blockquote>"
         "<h3>Source X-expression</h3>"
         "<pre>"
         (with-output-to-string (pretty-print-invalid-xexpr exn x))
         "</pre></body></html>")))))

  (define invalid-xexpr-handler (make-parameter default-error-handler))

  (define (convert-callbacks xexpr)
    (cond
      [(pair? xexpr)
       (cons (convert-callbacks (car xexpr))
             (convert-callbacks (cdr xexpr)))]
      [(procedure? xexpr)
       (callback-url xexpr)]
      [else xexpr]))

  (define-syntax web-page
    (syntax-rules ()
      [(_ e1 ... en)
       (send/suspend/dispatch
        (lambda (callback->url)
          (parameterize ([current-callback->url callback->url])
            (let ()
              e1 ...
              (let ([result en])
                (if (response/basic? result)
                    result
                    (let ([xexpr (convert-callbacks result)])
                      (with-handlers ([exn:invalid-xexpr?
                                       (lambda (exn)
                                         (let ([error-result ((invalid-xexpr-handler) exn xexpr)])
                                           (if (response/basic? error-result)
                                               error-result
                                               (with-handlers ([exn:invalid-xexpr?
                                                                (lambda (error-exn)
                                                                  (default-error-handler error-exn error-result))])
                                                 (validate-xexpr error-result)
                                                 error-result))))])
                        (validate-xexpr xexpr)
                        xexpr))))))))]))

  (provide web-page callback-url invalid-xexpr-handler))