(module xhtml mzscheme
(require (lib "servlet.ss" "web-server"))
(require (lib "xml.ss" "xml"))
(require (lib "etc.ss"))
(require (lib "string.ss"))
(require (lib "contract.ss"))
(define (accepted-mime-types request)
(with-handlers ([exn? (lambda (exn) null)])
(let ([header (extract-binding/single 'accept (request-headers request))])
(regexp-split #rx",[ \t\r\n]*"
(if (bytes? header)
(bytes->string/latin-1 header)
header)))))
(define (xhtml-mime-type request)
(if (and request (member "application/xhtml+xml" (accepted-mime-types request)))
#"application/xhtml+xml"
#"text/html"))
(define (make-doctype name path)
(format "<!DOCTYPE html PUBLIC \"-//W3C//DTD ~a//EN\" \"http://www.w3.org~a\">\n"
name
path))
(define xhtml1-transitional
(make-doctype "XHTML 1.0 Transitional"
"/TR/xhtml1/DTD/xhtml1-transitional.dtd"))
(define xhtml1-strict
(make-doctype "XHTML 1.0 Strict"
"/TR/xhtml1/DTD/xhtml1-strict.dtd"))
(define xhtml1-frameset
(make-doctype "XHTML 1.0 Frameset"
"/TR/xhtml1/DTD/xhtml1-frameset.dtd"))
(define xhtml1.1
(make-doctype "XHTML 1.1"
"/TR/xhtml11/DTD/xhtml11.dtd"))
(define xhtml2.0
(make-doctype "XHTML 2.0"
"/MarkUp/DTD/xhtml2.dtd"))
(define make-response/xhtml
(opt-lambda (xexpr [doctype xhtml1-transitional] [request #f])
(make-response/full
200
"Okay"
(current-seconds)
(xhtml-mime-type request)
null
(list doctype (xexpr->string xexpr)))))
(provide/contract
[xhtml-mime-type (request? . -> . bytes?)]
[make-response/xhtml ((xexpr?) (string? request?) . opt-> . response?)]
[xhtml1-transitional string?]
[xhtml1-strict string?]
[xhtml1-frameset string?]
[xhtml1.1 string?]
[xhtml2.0 string?]))