mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 20:20:24 +02:00
Code Activity

web server http: 400 Bad Request on bad requests

Browse source 
* module/web/server/http.scm (bad-request, http-read): If an exception
  is raised while reading a response, write out a 400 Bad Request
  response before closing the port.
This commit is contained in:
Andy Wingo 2012-03-11 10:29:06 +01:00
parent 9adbf27f4e
commit 02360ed605
1 changed files with 14 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

16
module/web/server/http.scm
View file

@ -1,6 +1,6 @@
;;; Web I/O: HTTP ;;; Web I/O: HTTP
;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -69,6 +69,11 @@
(poll-set-add! poll-set socket *events*) (poll-set-add! poll-set socket *events*)
(make-http-server socket 0 poll-set))) (make-http-server socket 0 poll-set)))
(define (bad-request port)
(write-response (build-response #:version '(1 . 0) #:code 400
#:headers '((content-length . 0)))
port))
;; -> (client request body | #f #f #f) ;; -> (client request body | #f #f #f)
(define (http-read server) (define (http-read server)
(let* ((poll-set (http-poll-set server))) (let* ((poll-set (http-poll-set server)))
@ -123,7 +128,14 @@
req req
(read-request-body req)))) (read-request-body req))))
(lambda (k . args) (lambda (k . args)
(false-if-exception (close-port port))))))))))))) (define-syntax-rule (cleanup-catch statement)
(catch #t
(lambda () statement)
(lambda (k . args)
(format (current-error-port) "In ~a:\n" 'statement)
(print-exception (current-error-port) #f k args))))
(cleanup-catch (bad-request port))
(cleanup-catch (close-port port)))))))))))))
(define (keep-alive? response) (define (keep-alive? response)
(let ((v (response-version response))) (let ((v (response-version response)))