diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 88d42d9796..d092e5008f 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -276,3 +276,7 @@ SYMBOL: a [ 4 ] [ a get-global ] unit-test [ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test + +! Test cloning +[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test +[ f ] [ <404> dup clone "b" "a" put-cookie drop "a" get-cookie ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 521c18c703..25bf20429d 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -6,7 +6,8 @@ assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present -io io.encodings.iana io.encodings.binary io.encodings.8-bit +io io.encodings io.encodings.iana io.encodings.binary +io.encodings.8-bit unicode.case unicode.categories qualified @@ -298,6 +299,11 @@ body ; latin1 >>content-charset V{ } clone >>cookies ; +M: response clone + call-next-method + [ clone ] change-header + [ clone ] change-cookies ; + : read-response-version ( response -- response ) " \t" read-until [ "Bad response: version" throw ] unless @@ -363,7 +369,11 @@ M: response write-response ( respose -- ) M: response write-full-response ( request response -- ) dup write-response - swap method>> "HEAD" = [ write-response-body ] unless ; + swap method>> "HEAD" = [ + [ content-charset>> encode-output ] + [ write-response-body ] + bi + ] unless ; : get-cookie ( request/response name -- cookie/f ) [ cookies>> ] dip '[ , _ name>> = ] find nip ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index dc66cb1507..f709939e21 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -60,23 +60,16 @@ main-responder global [ <404> or ] change-at swap development? get [ '[ , http-error. ] >>body ] [ drop ] if ; : do-response ( response -- ) - [ write-response ] + [ request get swap write-full-response ] [ - request get method>> "HEAD" = [ drop ] [ - '[ - , - [ content-charset>> encode-output ] - [ write-response-body ] - bi - ] - [ - utf8 [ - development? get - [ http-error. ] [ drop "Response error" rethrow ] if - ] with-encoded-output - ] recover - ] if - ] bi ; + [ \ do-response log-error ] + [ + utf8 [ + development? get + [ http-error. ] [ drop "Response error" write ] if + ] with-encoded-output + ] bi + ] recover ; LOG: httpd-hit NOTICE