diff options
| author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-14 22:34:05 +0200 |
|---|---|---|
| committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-04-14 22:34:05 +0200 |
| commit | 60c601831f8ac392efce5bc2b09e1df80d054ae8 (patch) | |
| tree | 11961b87c2f54fe0e7e9567a574f1aec6610c59c | |
| parent | Disable auto_compile while compiling. (diff) | |
| download | calp-60c601831f8ac392efce5bc2b09e1df80d054ae8.tar.gz calp-60c601831f8ac392efce5bc2b09e1df80d054ae8.tar.xz | |
WebDAV Fail properly on bad body.
| -rw-r--r-- | module/calp/server/webdav.scm | 56 |
1 files changed, 36 insertions, 20 deletions
diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm index 02c0acfa..f26b97f6 100644 --- a/module/calp/server/webdav.scm +++ b/module/calp/server/webdav.scm @@ -568,7 +568,7 @@ 'headers (request-headers request) 'request request) - (catch #t + (catch* (lambda () ;; TODO also log result of execution (call-with-values @@ -601,25 +601,41 @@ (emit-log!) (values head body)))) - (case-lambda ((err proc fmt args data) - (let ((head (build-response - code: 500 - headers: '((content-type . (text/plain))))) - (errmsg (if proc - (format #f "Error in ~a: ~?~%" proc fmt args) - (format #f "~?~%" fmt args)))) - (log-table-add! 'response head - 'response-code 500 - 'msg errmsg) - (emit-log!) - (values head errmsg))) - (err - (let ((errmsg (format #f "General error: ~s~%" err))) - (log-table-add! 'response-code 500 - 'msg errmsg) - (emit-log!) - (values (build-response code: 500) - errmsg)))))) + (parser-error + (lambda (err port msg . args) + (define head (build-response code: 400 + headers: '((content-type . (text/plain))))) + (define errmsg + (with-output-to-string + (lambda () + (display msg) + (for-each display args)))) + (log-table-add! 'response head + 'response-code 400 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + + (#t + (case-lambda ((err proc fmt args data) + (let ((head (build-response + code: 500 + headers: '((content-type . (text/plain))))) + (errmsg (if proc + (format #f "Error in ~a: ~?~%" proc fmt args) + (format #f "~?~%" fmt args)))) + (log-table-add! 'response head + 'response-code 500 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + (err + (let ((errmsg (format #f "General error: ~s~%" err))) + (log-table-add! 'response-code 500 + 'msg errmsg) + (emit-log!) + (values (build-response code: 500) + errmsg))))))) |