Working on new HTTP server

extra/assocs/lib/lib.factor

@@ -16,13 +16,16 @@ IN: assocs.lib
 : at-default ( key assoc -- value/key )
     dupd at [ nip ] when* ;
 
+: replace-at ( assoc value key -- assoc )
+    >r >r dup r> 1vector r> rot set-at ;
+
 : insert-at ( value key assoc -- )
     [ ?push ] change-at ;
 
-: peek-at* ( key assoc -- obj ? )
+: peek-at* ( assoc key -- obj ? )
-    at* dup [ >r peek r> ] when ;
+    swap at* dup [ >r peek r> ] when ;
 
-: peek-at ( key assoc -- obj )
+: peek-at ( assoc key -- obj )
     peek-at* drop ;
 
 : >multi-assoc ( assoc -- new-assoc )

extra/furnace/furnace.factor

@@ -35,6 +35,17 @@ SYMBOL: current-action
 SYMBOL: validators-errored
 SYMBOL: validation-errors
 
+: build-url ( str query-params -- newstr )
+    [
+        over %
+        dup assoc-empty? [
+            2drop
+        ] [
+            CHAR: ? rot member? "&" "?" ? %
+            assoc>query %
+        ] if
+    ] "" make ;
+
 : action-link ( query action -- url )
     [
         "/responder/" %

extra/http/client/client-tests.factor

@@ -1,14 +1,26 @@
-USING: http.client tools.test ;
+USING: http.client http.client.private http tools.test
+tuple-syntax namespaces ;
 [ "localhost" 80 ] [ "localhost" parse-host ] unit-test
 [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
-[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test
+[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
-[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test
+[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
-[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test
-[ 404 ] [ "404 File not found" parse-response ] unit-test
-[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test
-[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test
 
 [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
 [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
 [ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
 [ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
+
+[
+    TUPLE{ request
+        method: "GET"
+        host: "www.apple.com"
+        path: "/index.html"
+        port: 80
+    }
+] [
+    [
+        "http://www.apple.com/index.html"
+        <get-request>
+        request-with-url
+    ] with-scope
+] unit-test

extra/http/client/client.factor

@@ -2,64 +2,73 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs http kernel math math.parser namespaces sequences
 io io.sockets io.streams.string io.files io.timeouts strings
-splitting continuations assocs.lib calendar ;
+splitting continuations assocs.lib calendar vectors hashtables
+accessors ;
 IN: http.client
 
-: parse-host ( url -- host port )
+: parse-url ( url -- resource host port )
-    #! Extract the host name and port number from an HTTP URL.
+    "http://" ?head [ "Only http:// supported" throw ] unless
-    ":" split1 [ string>number ] [ 80 ] if* ;
-
-SYMBOL: domain
-
-: parse-url ( url -- host resource )
-    dup "https://" head? [
-        "ssl not yet supported: " swap append throw
-    ] when "http://" ?head drop
     "/" split1 [ "/" swap append ] [ "/" ] if*
-    >r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
+    swap parse-host ;
 
-: parse-response ( line -- code )
+<PRIVATE
-    "HTTP/" ?head [ " " split1 nip ] when
-    " " split1 drop string>number [
-        "Premature end of stream" throw
-    ] unless* ;
 
-: read-response ( -- code header )
+: store-path ( request path -- request )
-    #! After sending a GET or POST we read a response line and
+    "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
-    #! header.
-    flush readln parse-response read-header ;
 
-: crlf "\r\n" write ;
+! This is all pretty complex because it needs to handle
+! HTTP redirects, which might be absolute or relative
+: request-with-url ( url request -- request )
+    clone dup "request" set
+    swap parse-url >r >r store-path r> >>host r> >>port ;
 
-: http-request ( host resource method -- )
+DEFER: (http-request)
-    write bl write " HTTP/1.0" write crlf
-    "Host: " write write crlf ;
 
-: get-request ( host resource -- )
+: absolute-redirect ( url -- request )
-    "GET" http-request crlf ;
+    "request" get request-with-url ;
 
-DEFER: http-get-stream
+: relative-redirect ( path -- request )
+    "request" get swap store-path ;
 
-: do-redirect ( code headers stream -- code headers stream )
+: do-redirect ( response -- response stream )
-    #! Should this support Location: headers that are
+    dup response-code 300 399 between? [
-    #! relative URLs?
+        header>> "location" peek-at
-    pick 100 /i 3 = [
+        dup "http://" head? [
-        dispose "location" swap peek-at nip http-get-stream
+            absolute-redirect
-    ] when ;
+        ] [
+            relative-redirect
+        ] if "GET" >>method (http-request)
+    ] [
+        stdio get
+    ] if ;
 
-: default-timeout 1 minutes over set-timeout ;
+: (http-request) ( request -- response stream )
+    dup host>> over port>> <inet> <client> stdio set
+    write-request flush read-response
+    do-redirect ;
 
-: http-get-stream ( url -- code headers stream )
+PRIVATE>
-    #! Opens a stream for reading from an HTTP URL.
+
-    parse-url over parse-host <inet> <client> [
+: http-request ( url request -- response stream )
-        [ [ get-request read-response ] with-stream* ] keep
+    [
-        default-timeout
+        request-with-url
-    ] [ ] [ dispose ] cleanup do-redirect ;
+        [
+            (http-request)
+            1 minutes over set-timeout
+        ] [ ] [ stdio get dispose ] cleanup
+    ] with-scope ;
+
+: <get-request> ( -- request )
+    request construct-empty
+    "GET" >>method ;
+
+: http-get-stream ( url -- response stream )
+    <get-request> http-request ;
 
 : success? ( code -- ? ) 200 = ;
 
-: check-response ( code headers stream -- stream )
+: check-response ( response stream -- stream )
-    nip swap success?
+    swap code>> success?
     [ dispose "HTTP download failed" throw ] unless ;
 
 : http-get ( url -- string )
@@ -70,23 +79,18 @@ DEFER: http-get-stream
 
 : download-to ( url file -- )
     #! Downloads the contents of a URL to a file.
-    >r http-get-stream check-response
+    swap http-get-stream check-response
-    r> <file-writer> stream-copy ;
+    [ swap <file-writer> stream-copy ] with-disposal ;
 
 : download ( url -- )
     dup download-name download-to ;
 
-: post-request ( content-type content host resource -- )
+: <post-request> ( content-type content -- request )
-    #! Note: It is up to the caller to url encode the content if
+    request construct-empty
-    #! it is required according to the content-type.
+    "POST" >>method
-    "POST" http-request [
+    swap >>post-data
-        "Content-Length: " write length number>string write crlf
+    swap >>post-data-type ;
-        "Content-Type: " write url-encode write crlf
-        crlf
-    ] keep write ;
 
-: http-post ( content-type content url -- code headers string )
+: http-post ( content-type content url -- response string )
-    #! Make a POST request. The content is URL encoded for you.
+    #! The content is URL encoded for you.
-    parse-url over parse-host <inet> <client> [
+    -rot url-encode <post-request> http-request contents ;
-        post-request flush read-response stdio get contents
-    ] with-stream ;

extra/http/http-tests.factor

@@ -1,4 +1,5 @@
-USING: http tools.test ;
+USING: http tools.test multiline tuple-syntax
+io.streams.string kernel arrays splitting sequences     ;
 IN: temporary
 
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
@@ -16,3 +17,99 @@ IN: temporary
 [ "%20%21%20"     ] [ " ! "            url-encode ] unit-test
 
 [ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
+
+STRING: read-request-test-1
+GET http://foo/bar HTTP/1.1
+Some-Header: 1
+Some-Header: 2
+Content-Length: 4
+
+blah
+;
+
+[
+    TUPLE{ request
+        method: "GET"
+        path: "bar"
+        query: f
+        version: "1.1"
+        header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } }
+        post-data: "blah"
+    }
+] [
+    read-request-test-1 [
+        read-request
+    ] with-string-reader
+] unit-test
+
+STRING: read-request-test-1'
+GET bar HTTP/1.1
+content-length: 4
+some-header: 1
+some-header: 2
+
+blah
+;
+
+read-request-test-1' 1array [
+    read-request-test-1
+    [ read-request ] with-string-reader
+    [ write-request ] with-string-writer
+    ! normalize crlf
+    string-lines "\n" join
+] unit-test
+
+STRING: read-request-test-2
+HEAD  http://foo/bar   HTTP/1.0
+Host: www.sex.com
+;
+
+[
+    TUPLE{ request
+        method: "HEAD"
+        path: "bar"
+        query: f
+        version: "1.0"
+        header: H{ { "host" V{ "www.sex.com" } } }
+        host: "www.sex.com"
+    }
+] [
+    read-request-test-2 [
+        read-request
+    ] with-string-reader
+] unit-test
+
+STRING: read-response-test-1
+HTTP/1.0 404 not found
+Content-Type: text/html
+
+blah
+;
+
+[
+    TUPLE{ response
+        version: "1.0"
+        code: 404
+        message: "not found"
+        header: H{ { "content-type" V{ "text/html" } } }
+    }
+] [
+    read-response-test-1
+    [ read-response ] with-string-reader
+] unit-test
+
+
+STRING: read-response-test-1'
+HTTP/1.0 404 not found
+content-type: text/html
+
+
+;
+
+read-response-test-1' 1array [
+    read-response-test-1
+    [ read-response ] with-string-reader
+    [ write-response ] with-string-writer
+    ! normalize crlf
+    string-lines "\n" join
+] unit-test

extra/http/http.factor

@@ -1,19 +1,34 @@
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables io kernel math namespaces math.parser assocs
+USING: hashtables io io.streams.string kernel math namespaces
-sequences strings splitting ascii io.encodings.utf8 assocs.lib
+math.parser assocs sequences strings splitting ascii
-namespaces unicode.case ;
+io.encodings.utf8 assocs.lib namespaces unicode.case combinators
+vectors sorting new-slots accessors calendar ;
 IN: http
 
+: http-port 80 ; inline
+
+: crlf "\r\n" write ;
+
 : header-line ( line -- )
     ": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
 
-: (read-header) ( -- )
+: read-header-line ( -- )
     readln dup
-    empty? [ drop ] [ header-line (read-header) ] if ;
+    empty? [ drop ] [ header-line read-header-line ] if ;
 
-: read-header ( -- hash )
+: read-header ( -- multi-assoc )
-    [ (read-header) ] H{ } make-assoc ;
+    [ read-header-line ] H{ } make-assoc ;
+
+: write-header ( multi-assoc -- )
+    >alist sort-keys
+    [
+        swap write ": " write {
+            { [ dup number? ] [ number>string ] }
+            { [ dup timestamp? ] [ timestamp>http-string ] }
+            { [ dup string? ] [ ] }
+        } cond write crlf
+    ] multi-assoc-each crlf ;
 
 : url-quotable? ( ch -- ? )
     #! In a URL, can this character be used without
@@ -23,7 +38,7 @@ IN: http
     over digit? or
     swap "/_-." member? or ; foldable
 
-: push-utf8 ( string -- )
+: push-utf8 ( ch -- )
     1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
 
 : url-encode ( str -- str )
@@ -58,17 +73,205 @@ IN: http
 : url-decode ( str -- str )
     [ 0 swap url-decode-iter ] "" make decode-utf8 ;
 
-: hash>query ( hash -- str )
+: query>assoc ( query -- assoc )
+    dup [
+        "&" split [
+            "=" split1 [ dup [ url-decode ] when ] 2apply
+        ] H{ } map>assoc
+    ] when ;
+
+: assoc>query ( hash -- str )
     [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
     "&" join ;
 
-: build-url ( str query-params -- newstr )
+TUPLE: request
+host
+port
+method
+path
+query
+version
+header
+post-data
+post-data-type ;
+
+: <request>
+    request construct-empty
+    "1.0" >>version
+    http-port >>port ;
+
+: url>path ( url -- path )
+    url-decode "http://" ?head
+    [ "/" split1 "" or nip ] [ "/" ?head drop ] if ;
+
+: read-method ( request -- request )
+    " " read-until [ "Bad request: method" throw ] unless
+    >>method ;
+
+: read-query ( request -- request )
+    " " read-until
+    [ "Bad request: query params" throw ] unless
+    query>assoc >>query ;
+
+: read-url ( request -- request )
+    " ?" read-until {
+        { CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] }
+        { CHAR: ? [ url>path >>path read-query ] }
+        [ "Bad request: URL" throw ]
+    } case ;
+
+: parse-version ( string -- version )
+    "HTTP/" ?head [ "Bad version" throw ] unless
+    dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
+
+: read-request-version ( request -- request )
+    readln [ CHAR: \s = ] left-trim
+    parse-version
+    >>version ;
+
+: read-request-header ( request -- request )
+    read-header >>header ;
+
+SYMBOL: max-post-request
+
+1024 256 * max-post-request set-global
+
+: content-length ( header -- n )
+    "content-length" peek-at string>number dup [
+        dup max-post-request get > [
+            "content-length > max-post-request" throw
+        ] when
+    ] when ;
+
+: read-post-data ( request -- request )
+    dup header>> content-length [ read >>post-data ] when* ;
+
+: parse-host ( string -- host port )
+    "." ?tail drop ":" split1
+    [ string>number ] [ http-port ] if* ;
+
+: extract-host ( request -- request )
+    dup header>> "host" peek-at parse-host >r >>host r> >>port ;
+
+: extract-post-data-type ( request -- request )
+    dup header>> "content-type" peek-at >>post-data-type ;
+
+: read-request ( -- request )
+    <request>
+    read-method
+    read-url
+    read-request-version
+    read-request-header
+    read-post-data
+    extract-host
+    extract-post-data-type ;
+
+: write-method ( request -- request )
+    dup method>> write bl ;
+
+: write-url ( request -- request )
+    dup path>> url-encode write
+    dup query>> dup assoc-empty? [ drop ] [
+        "?" write
+        assoc>query write
+    ] if ;
+
+: write-request-url ( request -- request )
+    write-url bl ;
+
+: write-version ( request -- request )
+    "HTTP/" write dup request-version write crlf ;
+
+: write-request-header ( request -- request )
+    dup header>> >hashtable
+    over host>> [ "host" replace-at ] when*
+    over post-data>> [ length "content-length" replace-at ] when*
+    over post-data-type>> [ "content-type" replace-at ] when*
+    write-header ;
+
+: write-post-data ( request -- request )
+    dup post-data>> [ write ] when* ;
+
+: write-request ( request -- )
+    write-method
+    write-url
+    write-version
+    write-request-header
+    write-post-data
+    flush
+    drop ;
+
+: request-url ( request -- url )
     [
-        over %
+        dup host>> [
-        dup assoc-empty? [
+            "http://" write
-            2drop
+            dup host>> url-encode write
-        ] [
+            ":" write
-            CHAR: ? rot member? "&" "?" ? %
+            dup port>> number>string write
-            hash>query %
+        ] when
-        ] if
+        "/" write
-    ] "" make ;
+        write-url
+        drop
+    ] with-string-writer ;
+
+TUPLE: response
+version
+code
+message
+header ;
+
+: <response>
+    response construct-empty
+    "1.0" >>version
+    H{ } clone >>header ;
+
+: read-response-version
+    " " read-until
+    [ "Bad response: version" throw ] unless
+    parse-version
+    >>version ;
+
+: read-response-code
+    " " read-until [ "Bad response: code" throw ] unless
+    string>number [ "Bad response: code" throw ] unless*
+    >>code ;
+
+: read-response-message
+    readln >>message ;
+
+: read-response-header
+    read-header >>header ;
+
+: read-response ( -- response )
+    <response>
+    read-response-version
+    read-response-code
+    read-response-message
+    read-response-header ;
+
+: write-response-version ( response -- response )
+    "HTTP/" write
+    dup version>> write bl ;
+
+: write-response-code ( response -- response )
+    dup code>> number>string write bl ;
+
+: write-response-message ( response -- response )
+    dup message>> write crlf ;
+
+: write-response-header ( response -- response )
+    dup header>> write-header ;
+
+: write-response ( respose -- )
+    write-response-version
+    write-response-code
+    write-response-message
+    write-response-header
+    flush
+    drop ;
+
+: set-response-header ( response value key -- response )
+    pick header>> -rot replace-at drop ;
+
+: set-content-type ( response content-type -- response )
+    "content-type" set-response-header ;

extra/http/server/server-tests.factor

@@ -1,39 +1,45 @@
-USING: webapps.file http.server.responders http
+USING: http.server tools.test kernel namespaces accessors
-http.server namespaces io tools.test strings io.server
+new-slots assocs.lib io http math sequences ;
-logging ;
 IN: temporary
 
-[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test
+TUPLE: mock-responder ;
 
-[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
+: <mock-responder> ( path -- responder )
+    <responder> mock-responder construct-delegate ;
 
-[ "index.html" ]
+M: mock-responder do-responder
-[ "http://www.jedit.org/index.html" url>path ] unit-test
+    2nip
+    path>> on
+    [ "Hello world" print ]
+    "text/plain" <content> ;
 
-[ "foo/bar" ]
+: check-dispatch ( tag path -- ? )
-[ "http://www.jedit.org/foo/bar" url>path ] unit-test
+    over off
+    <request> swap default-host get call-responder
+    write-response call get ;
 
-[ "" ]
+[
-[ "http://www.jedit.org/" url>path ] unit-test
+    "" <dispatcher>
+        "foo" <mock-responder> add-responder
+        "bar" <mock-responder> add-responder
+        "baz/" <dispatcher>
+            "123" <mock-responder> add-responder
+            "default" <mock-responder> >>default
+        add-responder
+    default-host set
 
-[ "" ]
+    [ t ] [ "foo" "foo" check-dispatch ] unit-test
-[ "http://www.jedit.org" url>path ] unit-test
+    [ f ] [ "foo" "bar" check-dispatch ] unit-test
+    [ t ] [ "bar" "bar" check-dispatch ] unit-test
+    [ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
+    [ t ] [ "123" "baz/123" check-dispatch ] unit-test
 
-[ "foobar" ]
+    [ t ] [
-[ "foobar" secure-path ] unit-test
+        <request>
-
+        "baz" >>path
-[ f ]
+        "baz" default-host get call-responder
-[ "foobar/../baz" secure-path ] unit-test
+        dup code>> 300 399 between? >r
-
+        header>> "location" peek-at "baz/" tail? r> and
-[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test
+        nip
-[ ] [ f [ "POO" parse-request ] with-logging ] unit-test
+    ] unit-test
-
+] with-scope
-[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test
-
-[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ]
-[ "Foo=Bar&Baz=Quux" query>hash ] unit-test
-
-[ H{ { "Baz" " " } } ]
-[ "Baz=%20" query>hash ] unit-test
-
-[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test

extra/http/server/server.factor

@@ -1,65 +1,131 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel namespaces io io.timeouts strings splitting
-threads http http.server.responders sequences prettyprint
+threads http sequences prettyprint io.server logging calendar
-io.server logging calendar ;
+new-slots html.elements accessors math.parser combinators.lib ;
-
 IN: http.server
 
-: (url>path) ( uri -- path )
+TUPLE: responder path directory ;
-    url-decode "http://" ?head [
-        "/" split1 dup "" ? nip
-    ] when ;
 
-: url>path ( uri -- path )
+: <responder> ( path -- responder )
-    "?" split1 dup [
+    "/" ?tail responder construct-boa ;
-      >r (url>path) "?" r> 3append
-    ] [
-      drop (url>path)
-    ] if ;
 
-: secure-path ( path -- path )
+GENERIC: do-responder ( request path responder -- quot response )
-    ".." over subseq? [ drop f ] when ;
 
-: request-method ( cmd -- method )
+TUPLE: trivial-responder quot response ;
-    H{
-        { "GET" "get" }
-        { "POST" "post" }
-        { "HEAD" "head" }
-    } at "bad" or ;
 
-: (handle-request) ( arg cmd -- method path host )
+: <trivial-responder> ( quot response -- responder )
-    request-method dup "method" set swap
+    trivial-responder construct-boa
-    prepare-url prepare-header host ;
+    "" <responder> over set-delegate ;
 
-: handle-request ( arg cmd -- )
+M: trivial-responder do-responder
-    [ (handle-request) serve-responder ] with-scope ;
+    2nip dup quot>> swap response>> ;
 
-: parse-request ( request -- )
+: trivial-response-body ( code message -- )
-    " " split1 dup [
+    <html>
-        " HTTP" split1 drop url>path secure-path dup [
+        <body>
-            swap handle-request
+            <h1> swap number>string write bl write </h1>
-        ] [
+        </body>
-            2drop bad-request
+    </html> ;
-        ] if
-    ] [
-        2drop bad-request
-    ] if ;
 
-\ parse-request NOTICE add-input-logging
+: <trivial-response> ( code message -- quot response )
+    [ [ trivial-response-body ] 2curry ] 2keep <response>
+    "text/html" set-content-type
+    swap >>message
+    swap >>code ;
+
+: <404> ( -- quot response )
+    404 "Not Found" <trivial-response> ;
+
+: <redirect> ( to code message -- quot response )
+    <trivial-response>
+    rot "location" set-response-header ;
+
+: <permanent-redirect> ( to -- quot response )
+    301 "Moved Permanently" <redirect> ;
+
+: <temporary-redirect> ( to -- quot response )
+    307 "Temporary Redirect" <redirect> ;
+
+: <content> ( content-type -- response )
+    <response>
+    200 >>code
+    swap set-content-type ;
+
+TUPLE: dispatcher responders default ;
+
+: responder-matches? ( path responder -- ? )
+    path>> head? ;
+
+TUPLE: no-/-responder ;
+
+M: no-/-responder do-responder
+    2drop
+    dup path>> "/" append >>path
+    request-url <permanent-redirect> ;
+
+: <no-/-responder> ( -- responder )
+    "" <responder> no-/-responder construct-delegate ;
+
+<no-/-responder> no-/-responder set-global
+
+: find-responder ( path dispatcher -- path responder )
+    >r "/" ?head drop r>
+    [ responders>> [ dupd responder-matches? ] find nip ] keep
+    default>> or [ path>> ?head drop ] keep ;
+
+: no-trailing-/ ( path responder -- path responder )
+    over empty? over directory>> and
+    [ drop no-/-responder get-global ] when ;
+
+: call-responder ( request path responder -- quot response )
+    no-trailing-/ do-responder ;
+
+SYMBOL: 404-responder
+
+<404> <trivial-responder> 404-responder set-global
+
+M: dispatcher do-responder
+    find-responder call-responder ;
+
+: <dispatcher> ( path -- dispatcher )
+    <responder>
+    dispatcher construct-delegate
+    404-responder get-global >>default
+    V{ } clone >>responders ;
+
+: add-responder ( dispatcher responder -- dispatcher )
+    over responders>> push ;
+
+SYMBOL: virtual-hosts
+SYMBOL: default-host
+
+virtual-hosts global [ drop H{ } clone ] cache drop
+default-host global [ drop 404-responder ] cache drop
+
+: find-virtual-host ( host -- responder )
+    virtual-hosts get at [ default-host get ] unless* ;
+
+: handle-request ( request -- )
+    [
+        dup path>> over host>> find-virtual-host
+        call-responder
+        write-response
+    ] keep method>> "HEAD" = [ drop ] [ call ] if ;
+
+: default-timeout 1 minutes stdio get set-timeout ;
+
+LOG: httpd-hit NOTICE
+
+: log-request ( request -- )
+    { method>> host>> path>> } map-exec-with httpd-hit ;
 
 : httpd ( port -- )
     internet-server "http.server" [
-        1 minutes stdio get set-timeout
+        default-timeout
-        readln [ parse-request ] when*
+        read-request dup log-request handle-request
     ] with-server ;
 
 : httpd-main ( -- ) 8888 httpd ;
 
 MAIN: httpd-main
-
-! Load default webapps
-USE: webapps.file
-USE: webapps.callback
-USE: webapps.continuation
-USE: webapps.cgi