factor/extra/http/server/server.factor

! 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 sequences prettyprint io.server logging calendar http
html.streams html.elements accessors math.parser
combinators.lib tools.vocabs debugger continuations random
combinators destructors io.encodings.8-bit fry classes words
math rss json.writer ;
IN: http.server

! path is a sequence of path component strings

GENERIC: call-responder* ( path responder -- response )

: request-params ( request -- assoc )
    dup method>> {
        { "GET" [ query>> ] }
        { "HEAD" [ query>> ] }
        { "POST" [ post-data>> ] }
    } case ;

: <content> ( body content-type -- response )
    <response>
        200 >>code
        "Document follows" >>message
        swap >>content-type
        swap >>body ;

: <text-content> ( body -- response )
    "text/plain" <content> ;

: <html-content> ( body -- response )
    "text/html" <content> ;

: <xml-content> ( body -- response )
    "text/xml" <content> ;

: <feed-content> ( feed -- response )
    '[ , feed>xml ] "text/xml" <content> ;

: <json-content> ( obj -- response )
    '[ , >json ] "application/json" <content> ;

TUPLE: trivial-responder response ;

C: <trivial-responder> trivial-responder

M: trivial-responder call-responder* nip response>> call ;

: trivial-response-body ( code message -- )
    <html>
        <body>
            <h1> [ number>string write bl ] [ write ] bi* </h1>
        </body>
    </html> ;

: <trivial-response> ( code message -- response )
    2dup '[ , , trivial-response-body ] <html-content>
        swap >>message
        swap >>code ;

: <400> ( -- response )
    400 "Bad request" <trivial-response> ;

: <404> ( -- response )
    404 "Not Found" <trivial-response> ;

SYMBOL: 404-responder

[ <404> ] <trivial-responder> 404-responder set-global

SYMBOL: base-paths

: invert-slice ( slice -- slice' )
    dup slice? [
        [ seq>> ] [ from>> ] bi head-slice
    ] [
        drop { }
    ] if ;

: add-base-path ( path dispatcher -- )
    [ invert-slice ] [ class word-name ] bi*
    base-paths get set-at ;

: call-responder ( path responder -- response )
    [ add-base-path ] [ call-responder* ] 2bi ;

SYMBOL: link-hook

: add-link-hook ( quot -- )
    link-hook [ compose ] change ; inline

: modify-query ( query -- query )
    link-hook get call ;

: base-path ( string -- path )
    dup base-paths get at
    [ ] [ "No such responder: " swap append throw ] ?if ;

: resolve-base-path ( string -- string' )
    "$" ?head [
        [
            "/" split1 [ base-path [ "/" % % ] each "/" % ] dip %
        ] "" make
    ] when ;

: link>string ( url query -- url' )
    [ resolve-base-path ] [ modify-query ] bi* (link>string) ;

: write-link ( url query -- )
    link>string write ;

SYMBOL: form-hook

: add-form-hook ( quot -- )
    form-hook [ compose ] change ;

: hidden-form-field ( -- )
    form-hook get call ;

: absolute-redirect ( to query -- url )
    #! Same host.
    request get clone
    swap [ >>query ] when*
    swap url-encode >>path
    [ modify-query ] change-query
    request-url ;

: replace-last-component ( path with -- path' )
    [ "/" last-split1 drop "/" ] dip 3append ;

: relative-redirect ( to query -- url )
    request get clone
    swap [ >>query ] when*
    swap [ '[ , replace-last-component ] change-path ] when*
    [ modify-query ] change-query
    request-url ;

: derive-url ( to query -- url )
    {
        { [ over "http://" head? ] [ link>string ] }
        { [ over "/" head? ] [ absolute-redirect ] }
        { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }
        [ relative-redirect ]
    } cond ;

: <redirect> ( to query code message -- response )
    <trivial-response> -rot derive-url "location" set-header ;

\ <redirect> DEBUG add-input-logging

: <permanent-redirect> ( to query -- response )
    301 "Moved Permanently" <redirect> ;

: <temporary-redirect> ( to query -- response )
    307 "Temporary Redirect" <redirect> ;

: <standard-redirect> ( to query -- response )
    request get method>> "POST" =
    [ <permanent-redirect> ] [ <temporary-redirect> ] if ;

TUPLE: dispatcher default responders ;

: new-dispatcher ( class -- dispatcher )
    new
        404-responder get >>default
        H{ } clone >>responders ; inline

: <dispatcher> ( -- dispatcher )
    dispatcher new-dispatcher ;

: find-responder ( path dispatcher -- path responder )
    over empty? [
        "" over responders>> at*
        [ nip ] [ drop default>> ] if
    ] [
        over first over responders>> at*
        [ [ drop rest-slice ] dip ] [ drop default>> ] if
    ] if ;

M: dispatcher call-responder* ( path dispatcher -- response )
    find-responder call-responder ;

TUPLE: vhost-dispatcher default responders ;

: <vhost-dispatcher> ( -- dispatcher )
    404-responder get H{ } clone vhost-dispatcher boa ;

: find-vhost ( dispatcher -- responder )
    request get host>> over responders>> at*
    [ nip ] [ drop default>> ] if ;

M: vhost-dispatcher call-responder* ( path dispatcher -- response )
    find-vhost call-responder ;

: add-responder ( dispatcher responder path -- dispatcher )
    pick responders>> set-at ;

: add-main-responder ( dispatcher responder path -- dispatcher )
    [ add-responder drop ]
    [ drop "" add-responder drop ]
    [ 2drop ] 3tri ;

TUPLE: filter-responder responder ;

M: filter-responder call-responder*
    responder>> call-responder ;

SYMBOL: main-responder

main-responder global
[ drop 404-responder get-global ] cache
drop

SYMBOL: development-mode

: http-error. ( error -- )
    "Internal server error" [
        development-mode get [
            [ print-error nl :c ] with-html-stream
        ] [
            500 "Internal server error"
            trivial-response-body
        ] if
    ] simple-page ;

: <500> ( error -- response )
    500 "Internal server error" <trivial-response>
    swap '[ , http-error. ] >>body ;

: do-response ( response -- )
    dup write-response
    request get method>> "HEAD" =
    [ drop ] [
        '[
            , write-response-body
        ] [
            http-error.
        ] recover
    ] if ;

LOG: httpd-hit NOTICE

: log-request ( request -- )
    { method>> host>> path>> } map-exec-with httpd-hit ;

SYMBOL: exit-continuation

: exit-with exit-continuation get continue-with ;

: with-exit-continuation ( quot -- )
    '[ exit-continuation set @ ] callcc1 exit-continuation off ;

: split-path ( string -- path )
    "/" split harvest ;

: init-request ( -- )
    H{ } clone base-paths set
    [ ] link-hook set
    [ ] form-hook set ;

: do-request ( request -- response )
    [
        init-request
        [ request set ]
        [ log-request ]
        [ path>> split-path main-responder get call-responder ] tri
        [ <404> ] unless*
    ] [
        [ \ do-request log-error ]
        [ <500> ]
        bi
    ] recover ;

: ?refresh-all ( -- )
    development-mode get-global
    [ global [ refresh-all ] bind ] when ;

: handle-client ( -- )
    [
        1 minutes timeouts
        ?refresh-all
        read-request
        do-request
        do-response
    ] with-destructors ;

: httpd ( port -- )
    dup integer? [ internet-server ] when
    "http.server" latin1
    [ handle-client ] with-server ;

: httpd-main ( -- )
    8888 httpd ;

MAIN: httpd-main
Update for io.logging change 2008-02-07 02:05:10 -05:00			`! Copyright (C) 2003, 2008 Slava Pestov.`
Initial import 2007-09-20 18:09:08 -04:00			`! See http://factorcode.org/license.txt for BSD license.`
Redo timeouts 2008-02-09 22:34:42 -05:00			`USING: assocs kernel namespaces io io.timeouts strings splitting`
Another html.streasm usage 2008-05-23 18:45:33 -04:00			`threads sequences prettyprint io.server logging calendar http`
Reworking validation 2008-05-26 01:47:27 -04:00			`html.streams html.elements accessors math.parser`
			`combinators.lib tools.vocabs debugger continuations random`
			`combinators destructors io.encodings.8-bit fry classes words`
			`math rss json.writer ;`
Initial import 2007-09-20 18:09:08 -04:00			`IN: http.server`

Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`! path is a sequence of path component strings`

Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`GENERIC: call-responder* ( path responder -- response )`
HTTP server work in progress 2008-03-11 04:39:09 -04:00
Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`: request-params ( request -- assoc )`
			`dup method>> {`
Improving session management and action link generation 2008-03-13 23:14:32 -04:00			`{ "GET" [ query>> ] }`
			`{ "HEAD" [ query>> ] }`
			`{ "POST" [ post-data>> ] }`
			`} case ;`

Reworking validation 2008-05-26 01:47:27 -04:00			`: <content> ( body content-type -- response )`
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`<response>`
			`200 >>code`
Fix minor HTTPd omissions 2008-03-13 04:48:39 -04:00			`"Document follows" >>message`
Reworking validation 2008-05-26 01:47:27 -04:00			`swap >>content-type`
			`swap >>body ;`
Working on user capabilities 2008-05-01 17:24:50 -04:00
Reworking validation 2008-05-26 01:47:27 -04:00			`: <text-content> ( body -- response )`
			`"text/plain" <content> ;`

			`: <html-content> ( body -- response )`
			`"text/html" <content> ;`

			`: <xml-content> ( body -- response )`
			`"text/xml" <content> ;`

			`: <feed-content> ( feed -- response )`
			`'[ , feed>xml ] "text/xml" <content> ;`

			`: <json-content> ( obj -- response )`
			`'[ , >json ] "application/json" <content> ;`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`TUPLE: trivial-responder response ;`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`C: <trivial-responder> trivial-responder`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`M: trivial-responder call-responder* nip response>> call ;`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
			`: trivial-response-body ( code message -- )`
			`<html>`
			`<body>`
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`<h1> [ number>string write bl ] [ write ] bi* </h1>`
Working on new HTTP server 2008-02-25 15:53:18 -05:00			`</body>`
			`</html> ;`

New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`: <trivial-response> ( code message -- response )`
Working on user capabilities 2008-05-01 17:24:50 -04:00			`2dup '[ , , trivial-response-body ] <html-content>`
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`swap >>message`
			`swap >>code ;`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
Improving http.server's db support and actions 2008-03-03 05:40:29 -05:00			`: <400> ( -- response )`
			`400 "Bad request" <trivial-response> ;`

New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`: <404> ( -- response )`
Working on new HTTP server 2008-02-25 15:53:18 -05:00			`404 "Not Found" <trivial-response> ;`

New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`SYMBOL: 404-responder`

HTTP server work in progress 2008-03-11 04:39:09 -04:00			`[ <404> ] <trivial-responder> 404-responder set-global`

Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`SYMBOL: base-paths`

			`: invert-slice ( slice -- slice' )`
			`dup slice? [`
			`[ seq>> ] [ from>> ] bi head-slice`
			`] [`
			`drop { }`
			`] if ;`

			`: add-base-path ( path dispatcher -- )`
			`[ invert-slice ] [ class word-name ] bi*`
			`base-paths get set-at ;`

Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`: call-responder ( path responder -- response )`
			`[ add-base-path ] [ call-responder* ] 2bi ;`

Improving session management and action link generation 2008-03-13 23:14:32 -04:00			`SYMBOL: link-hook`

Start page flow code 2008-04-26 06:49:41 -04:00			`: add-link-hook ( quot -- )`
			`link-hook [ compose ] change ; inline`

Improving session management and action link generation 2008-03-13 23:14:32 -04:00			`: modify-query ( query -- query )`
Start page flow code 2008-04-26 06:49:41 -04:00			`link-hook get call ;`
Improving session management and action link generation 2008-03-13 23:14:32 -04:00
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`: base-path ( string -- path )`
			`dup base-paths get at`
			`[ ] [ "No such responder: " swap append throw ] ?if ;`

			`: resolve-base-path ( string -- string' )`
			`"$" ?head [`
			`[`
Reworking validation 2008-05-26 01:47:27 -04:00			`"/" split1 [ base-path [ "/" % % ] each "/" % ] dip %`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`] "" make`
			`] when ;`

Improving session management and action link generation 2008-03-13 23:14:32 -04:00			`: link>string ( url query -- url' )`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`[ resolve-base-path ] [ modify-query ] bi* (link>string) ;`
Improving session management and action link generation 2008-03-13 23:14:32 -04:00
			`: write-link ( url query -- )`
			`link>string write ;`

			`SYMBOL: form-hook`

Start page flow code 2008-04-26 06:49:41 -04:00			`: add-form-hook ( quot -- )`
			`form-hook [ compose ] change ;`

Improving session management and action link generation 2008-03-13 23:14:32 -04:00			`: hidden-form-field ( -- )`
Start page flow code 2008-04-26 06:49:41 -04:00			`form-hook get call ;`
HTTP server work in progress 2008-03-11 04:39:09 -04:00
			`: absolute-redirect ( to query -- url )`
			`#! Same host.`
			`request get clone`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`swap [ >>query ] when*`
			`swap url-encode >>path`
			`[ modify-query ] change-query`
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`request-url ;`

			`: replace-last-component ( path with -- path' )`
Reworking validation 2008-05-26 01:47:27 -04:00			`[ "/" last-split1 drop "/" ] dip 3append ;`
New HTTPD work in progress 2008-02-29 01:57:38 -05:00
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`: relative-redirect ( to query -- url )`
			`request get clone`
			`swap [ >>query ] when*`
			`swap [ '[ , replace-last-component ] change-path ] when*`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`[ modify-query ] change-query`
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`request-url ;`

			`: derive-url ( to query -- url )`
More httpd work 2008-03-03 03:19:36 -05:00			`{`
Improving session management and action link generation 2008-03-13 23:14:32 -04:00			`{ [ over "http://" head? ] [ link>string ] }`
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`{ [ over "/" head? ] [ absolute-redirect ] }`
Reworking validation 2008-05-26 01:47:27 -04:00			`{ [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] }`
cond/case 2008-04-11 13:55:57 -04:00			`[ relative-redirect ]`
More httpd work 2008-03-03 03:19:36 -05:00			`} cond ;`

HTTP server work in progress 2008-03-11 04:39:09 -04:00			`: <redirect> ( to query code message -- response )`
			`<trivial-response> -rot derive-url "location" set-header ;`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`\ <redirect> DEBUG add-input-logging`

HTTP server work in progress 2008-03-11 04:39:09 -04:00			`: <permanent-redirect> ( to query -- response )`
Working on new HTTP server 2008-02-25 15:53:18 -05:00			`301 "Moved Permanently" <redirect> ;`

HTTP server work in progress 2008-03-11 04:39:09 -04:00			`: <temporary-redirect> ( to query -- response )`
Working on new HTTP server 2008-02-25 15:53:18 -05:00			`307 "Temporary Redirect" <redirect> ;`

Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`: <standard-redirect> ( to query -- response )`
			`request get method>> "POST" =`
			`[ <permanent-redirect> ] [ <temporary-redirect> ] if ;`

New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`TUPLE: dispatcher default responders ;`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
Some minor improvements to http.server 2008-04-14 05:34:26 -04:00			`: new-dispatcher ( class -- dispatcher )`
Merge with erg's changes 2008-04-14 05:42:43 -04:00			`new`
Some minor improvements to http.server 2008-04-14 05:34:26 -04:00			`404-responder get >>default`
			`H{ } clone >>responders ; inline`

More httpd work 2008-03-03 03:19:36 -05:00			`: <dispatcher> ( -- dispatcher )`
Some minor improvements to http.server 2008-04-14 05:34:26 -04:00			`dispatcher new-dispatcher ;`
More httpd work 2008-03-03 03:19:36 -05:00
New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`: find-responder ( path dispatcher -- path responder )`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`over empty? [`
			`"" over responders>> at*`
			`[ nip ] [ drop default>> ] if`
New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`] [`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`over first over responders>> at*`
Reworking validation 2008-05-26 01:47:27 -04:00			`[ [ drop rest-slice ] dip ] [ drop default>> ] if`
New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`] if ;`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`M: dispatcher call-responder* ( path dispatcher -- response )`
			`find-responder call-responder ;`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00
Persistent sessions 2008-03-15 07:22:47 -04:00			`TUPLE: vhost-dispatcher default responders ;`

			`: <vhost-dispatcher> ( -- dispatcher )`
construct-boa -> boa construct-empty -> new 2008-04-13 16:06:27 -04:00			`404-responder get H{ } clone vhost-dispatcher boa ;`
Persistent sessions 2008-03-15 07:22:47 -04:00
			`: find-vhost ( dispatcher -- responder )`
			`request get host>> over responders>> at*`
			`[ nip ] [ drop default>> ] if ;`

Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`M: vhost-dispatcher call-responder* ( path dispatcher -- response )`
Persistent sessions 2008-03-15 07:22:47 -04:00			`find-vhost call-responder ;`

New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`: add-responder ( dispatcher responder path -- dispatcher )`
			`pick responders>> set-at ;`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
More httpd work 2008-03-03 03:19:36 -05:00			`: add-main-responder ( dispatcher responder path -- dispatcher )`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`[ add-responder drop ]`
			`[ drop "" add-responder drop ]`
			`[ 2drop ] 3tri ;`
More httpd work 2008-03-03 03:19:36 -05:00
Merge URL and cookie session managers, clean up some code 2008-04-26 19:56:51 -04:00			`TUPLE: filter-responder responder ;`

Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`M: filter-responder call-responder*`
Merge URL and cookie session managers, clean up some code 2008-04-26 19:56:51 -04:00			`responder>> call-responder ;`

HTTP server work in progress 2008-03-11 04:39:09 -04:00			`SYMBOL: main-responder`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`main-responder global`
			`[ drop 404-responder get-global ] cache`
			`drop`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
More httpd work 2008-03-03 03:19:36 -05:00			`SYMBOL: development-mode`

Working on planet factor rewrite 2008-04-22 22:08:27 -04:00			`: http-error. ( error -- )`
			`"Internal server error" [`
			`development-mode get [`
			`[ print-error nl :c ] with-html-stream`
			`] [`
			`500 "Internal server error"`
			`trivial-response-body`
			`] if`
			`] simple-page ;`

New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`: <500> ( error -- response )`
			`500 "Internal server error" <trivial-response>`
Working on planet factor rewrite 2008-04-22 22:08:27 -04:00			`swap '[ , http-error. ] >>body ;`
New HTTPD work in progress 2008-02-29 01:57:38 -05:00
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`: do-response ( response -- )`
New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`dup write-response`
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`request get method>> "HEAD" =`
Working on planet factor rewrite 2008-04-22 22:08:27 -04:00			`[ drop ] [`
			`'[`
			`, write-response-body`
			`] [`
			`http-error.`
			`] recover`
			`] if ;`
Working on new HTTP server 2008-02-25 15:53:18 -05:00
			`LOG: httpd-hit NOTICE`

			`: log-request ( request -- )`
			`{ method>> host>> path>> } map-exec-with httpd-hit ;`
New logging framework 2008-02-07 18:07:43 -05:00
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`SYMBOL: exit-continuation`

			`: exit-with exit-continuation get continue-with ;`

Working on HTTP server 2008-03-17 05:31:13 -04:00			`: with-exit-continuation ( quot -- )`
			`'[ exit-continuation set @ ] callcc1 exit-continuation off ;`

Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`: split-path ( string -- path )`
sift and harvest words added 2008-05-14 00:36:55 -04:00			`"/" split harvest ;`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00
Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`: init-request ( -- )`
			`H{ } clone base-paths set`
			`[ ] link-hook set`
			`[ ] form-hook set ;`

HTTP server work in progress 2008-03-11 04:39:09 -04:00			`: do-request ( request -- response )`
Working on HTTP server 2008-03-17 05:31:13 -04:00			`[`
Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`init-request`
Working on HTTP server 2008-03-17 05:31:13 -04:00			`[ request set ]`
Improved cookie support, and better session manager taking advantage of it 2008-04-27 04:09:00 -04:00			`[ log-request ]`
Improved HTTP server dispatcher 2008-04-25 04:23:47 -04:00			`[ path>> split-path main-responder get call-responder ] tri`
Working on HTTP server 2008-03-17 05:31:13 -04:00			`[ <404> ] unless*`
			`] [`
			`[ \ do-request log-error ]`
			`[ <500> ]`
			`bi`
			`] recover ;`
HTTP server work in progress 2008-03-11 04:39:09 -04:00
http.server form validation 2008-03-05 22:38:15 -05:00			`: ?refresh-all ( -- )`
New HTTPD work in progress 2008-02-29 01:57:38 -05:00			`development-mode get-global`
http.server form validation 2008-03-05 22:38:15 -05:00			`[ global [ refresh-all ] bind ] when ;`

			`: handle-client ( -- )`
			`[`
Split stdio up into input-stream/output-stream, pipes work in progress 2008-05-05 03:19:25 -04:00			`1 minutes timeouts`
http.server form validation 2008-03-05 22:38:15 -05:00			`?refresh-all`
			`read-request`
HTTP server work in progress 2008-03-11 04:39:09 -04:00			`do-request`
			`do-response`
http.server form validation 2008-03-05 22:38:15 -05:00			`] with-destructors ;`
New HTTPD work in progress 2008-02-29 01:57:38 -05:00
Initial import 2007-09-20 18:09:08 -04:00			`: httpd ( port -- )`
Another html.streasm usage 2008-05-23 18:45:33 -04:00			`dup integer? [ internet-server ] when`
			`"http.server" latin1`
			`[ handle-client ] with-server ;`
Initial import 2007-09-20 18:09:08 -04:00
Another html.streasm usage 2008-05-23 18:45:33 -04:00			`: httpd-main ( -- )`
			`8888 httpd ;`
Initial import 2007-09-20 18:09:08 -04:00
			`MAIN: httpd-main`