(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))