diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 1a74e3fc6d..ed146d98de 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -235,6 +235,13 @@ test-db [ servers>> random addr>> port>> ] with-scope "port" set ; +: add-port ( url -- url' ) + >url clone "port" get >>port ; + +: stop-test-httpd ( -- ) + "http://localhost/quit" add-port http-get nip + "Goodbye" assert= ; + [ ] [ add-quit-action @@ -248,9 +255,6 @@ test-db [ test-httpd ] unit-test -: add-port ( url -- url' ) - >url clone "port" get >>port ; - [ t ] [ "vocab:http/test/foo.html" ascii file-contents "http://localhost/nested/foo.html" add-port http-get nip = @@ -279,7 +283,7 @@ test-db [ [ ] [ - [ "http://localhost/quit" add-port http-get 2drop ] ignore-errors + [ stop-test-httpd ] ignore-errors ] unit-test ! Dispatcher bugs @@ -402,7 +406,7 @@ SYMBOL: a "vocab:http/test/foo.html" ascii file-contents = ] unit-test -[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test +[ ] [ stop-test-httpd ] unit-test ! Check behavior of 307 redirect (reported by Chris Double) [ ] [ @@ -429,4 +433,16 @@ SYMBOL: a ] with-directory ] must-fail -[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test +[ ] [ stop-test-httpd ] unit-test + +! Check that index.fhtml works +[ ] [ + + "resource:basis/http/test/" enable-fhtml >>default + add-quit-action + test-httpd +] unit-test + +[ "OK\n\n" ] [ "http://localhost/" add-port http-get nip ] unit-test + +[ ] [ stop-test-httpd ] unit-test diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 6b65cd5fe4..294c3d7a0d 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -7,9 +7,10 @@ io.files.info io.directories io.pathnames io.encodings.binary fry xml.entities destructors urls html xml.syntax html.templates.fhtml http http.server http.server.responses http.server.redirection xml.writer ; +FROM: sets => adjoin ; IN: http.server.static -TUPLE: file-responder root hook special allow-listings ; +TUPLE: file-responder root hook special index-names allow-listings ; : modified-since ( request -- date ) "if-modified-since" header ";" split1 drop @@ -23,7 +24,8 @@ TUPLE: file-responder root hook special allow-listings ; file-responder new swap >>hook swap >>root - H{ } clone >>special ; + H{ } clone >>special + V{ "index.html" } >>index-names ; : (serve-static) ( path mime-type -- response ) [ @@ -75,7 +77,9 @@ TUPLE: file-responder root hook special allow-listings ; ] if ; : find-index ( filename -- path ) - "index.html" append-path dup exists? [ drop f ] unless ; + file-responder get index-names>> + [ append-path dup exists? [ drop f ] unless ] with map-find + drop ; : serve-directory ( filename -- response ) url get path>> "/" tail? [ @@ -97,8 +101,12 @@ M: file-responder call-responder* ( path responder -- response ) ".." over member? [ drop <400> ] [ "/" join serve-object ] if ; -! file responder integration +: add-index ( name responder -- ) + index-names>> adjoin ; + +: serve-fhtml ( path -- response ) + "text/html" ; + : enable-fhtml ( responder -- responder ) - [ "text/html" ] - "application/x-factor-server-page" - pick special>> set-at ; + [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at + "index.fhtml" over add-index ; diff --git a/basis/http/test/index.fhtml b/basis/http/test/index.fhtml new file mode 100644 index 0000000000..72a9c87242 --- /dev/null +++ b/basis/http/test/index.fhtml @@ -0,0 +1 @@ +<% USE: io "OK" write %>