From 12dcbfdc88c3630bfad1265d963790a6ebd6cd24 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 27 Feb 2009 21:11:01 +0000 Subject: [PATCH] Fixing xexpr pretty printing svn: r13875 --- .../web-server/configuration/responders.ss | 6 +- .../htdocs/servlets/examples/bad-xexpr.ss | 5 ++ collects/web-server/formlets/input.ss | 4 +- collects/web-server/formlets/lib.ss | 6 +- collects/web-server/formlets/servlet.ss | 6 +- collects/web-server/http/cookie.ss | 3 +- collects/web-server/http/response-structs.ss | 5 +- collects/web-server/private/xexpr.ss | 69 ++++++++----------- collects/xml/private/xexpr.ss | 11 +++ 9 files changed, 63 insertions(+), 52 deletions(-) create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/bad-xexpr.ss diff --git a/collects/web-server/configuration/responders.ss b/collects/web-server/configuration/responders.ss index 0bd850148f..b5e48f631c 100644 --- a/collects/web-server/configuration/responders.ss +++ b/collects/web-server/configuration/responders.ss @@ -1,8 +1,8 @@ #lang scheme (require scheme/runtime-path net/url - web-server/http/response-structs web-server/private/xexpr + web-server/http/response-structs web-server/http/request-structs) (define (format-stack-trace trace) @@ -33,7 +33,9 @@ (div ([class "title"]) "Exception") (p "The application raised an exception with the message:" - (pre ,(reformat-xexpr-exn (exn-message exn)))) + (pre ,(if (exn:pretty? exn) + (exn:pretty-xexpr exn) + (exn-message exn)))) (p "Stack trace:" ,(format-stack-trace diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/bad-xexpr.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/bad-xexpr.ss new file mode 100644 index 0000000000..3cc06dcee9 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/bad-xexpr.ss @@ -0,0 +1,5 @@ +#lang web-server/insta +(define (start initial-request) + `(html (head (title "Foo")) + (body (a ([href #f]) + "Zog")))) \ No newline at end of file diff --git a/collects/web-server/formlets/input.ss b/collects/web-server/formlets/input.ss index 4312d65967..967af28fc2 100644 --- a/collects/web-server/formlets/input.ss +++ b/collects/web-server/formlets/input.ss @@ -1,6 +1,6 @@ #lang scheme (require web-server/http - xml + web-server/private/xexpr (only-in "lib.ss" formlet/c pure @@ -31,7 +31,7 @@ default)))) (provide/contract - [make-input ((string? . -> . xexpr/c) . -> . (formlet/c (or/c false/c binding?)))] + [make-input ((string? . -> . pretty-xexpr/c) . -> . (formlet/c (or/c false/c binding?)))] #;[binding:form-required (formlet/c (binding? . -> . bytes?))] #;[binding:form/default (bytes? . -> . (formlet/c (binding? . -> . bytes?)))]) diff --git a/collects/web-server/formlets/lib.ss b/collects/web-server/formlets/lib.ss index cc7fe46b6e..f1945f2761 100644 --- a/collects/web-server/formlets/lib.ss +++ b/collects/web-server/formlets/lib.ss @@ -1,6 +1,6 @@ #lang scheme (require web-server/http - xml) + web-server/private/xexpr) ; Combinators (define (const x) (lambda _ x)) @@ -68,7 +68,7 @@ ; Contracts (define xexpr-forest/c - (listof xexpr/c)) + (listof pretty-xexpr/c)) (define (formlet/c c) (integer? . -> . @@ -91,7 +91,7 @@ () #:rest (listof (formlet/c alpha)) . ->* . (formlet/c beta))] [xml-forest (xexpr-forest/c . -> . (formlet/c procedure?))] - [xml (xexpr/c . -> . (formlet/c procedure?))] + [xml (pretty-xexpr/c . -> . (formlet/c procedure?))] [text (string? . -> . (formlet/c procedure?))] [tag-xexpr (symbol? (listof (list/c symbol? string?)) (formlet/c alpha) . -> . (formlet/c alpha))] [formlet-display ((formlet/c alpha) . -> . xexpr-forest/c)] diff --git a/collects/web-server/formlets/servlet.ss b/collects/web-server/formlets/servlet.ss index ef9b8fd882..6d1d1f6827 100644 --- a/collects/web-server/formlets/servlet.ss +++ b/collects/web-server/formlets/servlet.ss @@ -1,11 +1,11 @@ #lang scheme (require web-server/servlet - xml + web-server/private/xexpr "lib.ss") (provide/contract [send/formlet (((formlet/c any/c)) - (#:wrap (xexpr/c . -> . response/c)) + (#:wrap (pretty-xexpr/c . -> . response/c)) . ->* . any/c)]) (define (send/formlet f @@ -23,7 +23,7 @@ ,@(formlet-display f))))))) (provide/contract - [embed-formlet (embed/url/c (formlet/c any/c) . -> . xexpr/c)]) + [embed-formlet (embed/url/c (formlet/c any/c) . -> . pretty-xexpr/c)]) (define (embed-formlet embed/url f) `(form ([action ,(embed/url diff --git a/collects/web-server/http/cookie.ss b/collects/web-server/http/cookie.ss index 7e4aab5b58..6853dfac13 100644 --- a/collects/web-server/http/cookie.ss +++ b/collects/web-server/http/cookie.ss @@ -3,6 +3,7 @@ web-server/http/request-structs web-server/http/response-structs xml + web-server/private/xexpr scheme/contract) (provide/contract @@ -13,7 +14,7 @@ #:secure? (or/c false/c boolean?)) . ->* . cookie?)] [cookie->header (cookie? . -> . header?)] - [xexpr-response/cookies ((listof cookie?) xexpr/c . -> . response/full?)]) + [xexpr-response/cookies ((listof cookie?) pretty-xexpr/c . -> . response/full?)]) (define (set-when-true fn val) (if val diff --git a/collects/web-server/http/response-structs.ss b/collects/web-server/http/response-structs.ss index 94a6181d48..32ba8d11d3 100644 --- a/collects/web-server/http/response-structs.ss +++ b/collects/web-server/http/response-structs.ss @@ -1,7 +1,8 @@ #lang scheme/base (require mzlib/contract scheme/list - xml/xml + xml + web-server/private/xexpr web-server/http/request-structs) (define TEXT/HTML-MIME-TYPE #"text/html; charset=utf-8") @@ -13,7 +14,7 @@ (define response/c (or/c response/basic? (cons/c bytes? (listof (or/c string? bytes?))) - xexpr/c)) + pretty-xexpr/c)) ;; response/full->size: response/full -> number (define (response/full->size resp) diff --git a/collects/web-server/private/xexpr.ss b/collects/web-server/private/xexpr.ss index 9cdf527848..0b9ec14e37 100644 --- a/collects/web-server/private/xexpr.ss +++ b/collects/web-server/private/xexpr.ss @@ -2,13 +2,38 @@ (require scheme/pretty xml) +(define-struct (exn:pretty exn) (xexpr)) + (provide/contract + [struct (exn:pretty exn) ([message string?] + [continuation-marks continuation-mark-set?] + [xexpr xexpr/c])] [format-xexpr/errors (any/c . -> . string?)] - [reformat-xexpr-exn (string? . -> . xexpr/c)]) + [pretty-xexpr/c contract?]) + +(define pretty-xexpr/c + (make-proj-contract + 'pretty-xexpr/c + (lambda (pos neg src-info name) + (lambda (val) + (define marks (current-continuation-marks)) + (with-handlers ([exn:fail:contract? + (lambda (exn) + (raise + (make-exn:pretty + (exn-message exn) + marks + `(span ,(drop-after "Context:\n" (exn-message exn)) + ,(make-cdata #f #f (format-xexpr/errors val))))))]) + (contract xexpr/c val pos neg src-info)))) + (lambda (v) #t))) + +(define (drop-after delim str) + (substring str 0 (cdr (first (regexp-match-positions (regexp-quote delim) str))))) ; Formating Xexprs (define (format-xexpr/errors v) - (pretty-format (format-xexpr v))) + (pretty-format (format-xexpr v) 80)) (define-struct xexpr-error (message content) #:property prop:custom-write @@ -27,6 +52,7 @@ (exact-nonnegative-integer? v) (comment? v) (p-i? v) + (pcdata? v) (cdata? v))) (define (format-xexpr v) @@ -43,7 +69,7 @@ (format-elements+attributes (cdr v)))])] [(xexpr-datum? v) v] [else - (mark-error "Not a valid Xexpr datum (Must be a string, symbol, exact nonnegative integer, comment, PI, or cdata.)" v)])) + (mark-error "Not a valid Xexpr datum (Must be a string, symbol, exact nonnegative integer, comment, PI, pcdata, or cdata.)" v)])) (define (format-elements+attributes l) (match l @@ -87,39 +113,4 @@ [(list attr (? string? val)) (list (mark-error "Not a valid attribute name (Must be symbol.)" attr) val)] [else - (mark-error "Not a valid attribute (Must be a list of a symbol and a string.)" l)])) - -; Reformating Xexpr errors -(define (parse-xexpr-error s) - (with-input-from-string - s (lambda () - (define violator (read)) - (define c:broke (read)) - (define c:the (read)) - (define c:contract (read)) - (define contract-expr (read)) - (define c:on (read)) - (define contracted (read)) - (define c:semi (read-char)) - (define xml:msg (read-line)) - (define blank (read-line)) - (define c:context (read-line)) - (define not-xexpr (read)) - (when - (or (ormap eof-object? - (list violator c:broke c:the c:contract contract-expr - c:on contracted c:semi xml:msg blank c:context not-xexpr)) - (not (andmap symbol=? - (list 'broke 'the 'contract 'on '|;| 'Context:) - (list c:broke c:the c:contract c:on c:semi c:context)))) - (error 'parse-xexpr-error "Not Xexpr error")) - (values violator contract-expr contracted xml:msg not-xexpr)))) - -(define (reformat-xexpr-exn m) - (with-handlers ([exn? (lambda _ m)]) - (define-values (violator contract-expr contracted xml:msg not-xexpr) - (parse-xexpr-error m)) - `(span ,(format "~a broke the contract~n~a~non ~a;~a~n~nContext:~n" - violator (pretty-format contract-expr) contracted - xml:msg) - ,(make-cdata #f #f (format-xexpr/errors not-xexpr))))) + (mark-error "Not a valid attribute (Must be a list of a symbol and a string.)" l)])) \ No newline at end of file diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss index aa9dc0cac2..38fdf7616d 100644 --- a/collects/xml/private/xexpr.ss +++ b/collects/xml/private/xexpr.ss @@ -21,6 +21,17 @@ (define xexpr-drop-empty-attributes (make-parameter #f)) +(define xexpr-datum/c + (or/c string? symbol? exact-nonnegative-integer? + comment? p-i? cdata? pcdata?)) + +#;(define xexpr/c + (flat-rec-contract xexpr + xexpr-datum/c + (cons/c symbol? + (or/c (cons/c (listof (list/c symbol? string?)) (listof xexpr)) + (listof xexpr))))) + (define xexpr/c (make-proj-contract 'xexpr?