#lang scheme/base

(require (for-syntax scheme/base)
         net/url
         web-server/http
         (planet untyped/mirrors:1)
         scheme/contract
         scheme/runtime-path)

(define-runtime-path default-mime-types-path
  "mime.types")

(define default-servlet-path
  (build-path (current-directory) "servlet.ss"))

(define default-htdocs-paths
  (list (build-path (current-directory) "htdocs")))

(define default-servlet-namespace null)

(define (default-servlet-exn-handler url exn)
  (define trace
    (xml (pre ,@(for/list ([item (in-list (continuation-mark-set->context (exn-continuation-marks exn)))])
                  (format "~a at:~n  ~a~n"
                          (or (car item) "<unknown procedure>")
                          (if (cdr item)
                              (format "line ~a, column ~a, in file ~a"
                                      (srcloc-line (cdr item))
                                      (srcloc-column (cdr item))
                                      (srcloc-source (cdr item)))
                              "<unknown location>"))))))
  (make-html-response
   #:code 500
   (xml (html (head (title "Servlet Error")
                    (style (@ [type "text/css"])
                           (!raw #<<EOF
.section {
  margin: 25px;
  font-family: sans-serif;
  border: 1px solid black;
}

.title {
  background-color: #663366;
  font-size: large;
  padding: 5px;
  color: #FFFFFF;
}

.section > p {
  margin-left: 5px;
  margin-right: 5px;
}

.section > pre {
  background-color: #ffccff;
  margin-left: 5px;
  margin-right: 5px;
  padding: 5px;
  border: 1px solid #ff99ff;
}
EOF
                                 )))
              (body (div (@ [class "section"])
                         (div (@ [class "title"]) "Exception")
                         (p "Your application raised an exception with the message:"
                            (pre ,(exn-message exn)))
                         (p "Stack trace:" ,trace)))))))

; Provide statements -----------------------------

(provide/contract
 [default-mime-types-path     path?]
 [default-servlet-path        path?]
 [default-htdocs-paths        (listof path?)]
 [default-servlet-namespace   list?]
 [default-servlet-exn-handler (-> (or/c string? url?) exn? response?)])