factor/libs/httpd/responder.factor

! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: httpd
USING: arrays hashtables html http io kernel math namespaces
parser sequences strings ;

! Variables
SYMBOL: vhosts
SYMBOL: responders

: print-header ( alist -- )
    [ swap write ": " write print ] hash-each ;

: response ( header msg -- )
    "HTTP/1.0 " write print print-header ;

: error-body ( error -- body )
    <html> <body> <h1> write </h1> </body> </html> ;

: error-head ( error -- )
    dup log-error
    H{ { "Content-Type" "text/html" } } over response ;

: httpd-error ( error -- )
    #! This must be run from handle-request
    error-head
    "head" "method" get = [ drop ] [ terpri error-body ] if ;

: bad-request ( -- )
    [
        ! Make httpd-error print a body
        "get" "method" set
        "400 Bad request" httpd-error
    ] with-scope ;

: serving-content ( mime -- )
    "Content-Type" associate
    "200 Document follows" response terpri ;

: serving-html "text/html" serving-content ;

: serving-text "text/plain" serving-content ;

: redirect ( to -- )
    "Location" associate
    "301 Moved Permanently" response terpri ;

: directory-no/ ( -- )
    [
        "request" get % CHAR: / ,
        "raw-query" get [ CHAR: ? , % ] when*
    ] "" make redirect ;

: query>hash ( query -- hash )
    dup [
        "&" split [
            "=" split1 [ dup [ url-decode ] when ] 2apply 2array
        ] map
    ] when alist>hash ;

: read-post-request ( header -- hash )
    "Content-Length" swap hash dup
    [ string>number read dup "raw-response" set query>hash ] when ;

: log-headers ( hash -- )
    [
        drop { "User-Agent" "X-Forwarded-For" "Host" } member?
    ] hash-subset [ ": " swap 3append log-message ] hash-each ;

: prepare-url ( url -- url )
    #! This is executed in the with-request namespace.
    "?" split1
    dup "raw-query" set query>hash "query" set
    dup "request" set ;

: prepare-header ( -- )
    read-header dup "header" set
    dup log-headers
    read-post-request "response" set ;

! Responders are called in a new namespace with these
! variables:

! - method -- one of get, post, or head.
! - request -- the entire URL requested, including responder
!              name
! - raw-query -- raw query string
! - query -- a hashtable of query parameters, eg
!            foo.bar?a=b&c=d becomes
!            H{ { "a" "b" } { "c" "d" } }
! - header -- a hashtable of headers from the user's client
! - response -- a hashtable of the POST request response
! - raw-response -- raw POST request response

: query-param ( key -- value ) "query" get hash ;

: add-responder ( responder -- )
    #! Add a responder object to the list.
    "responder" over hash  responders get set-hash ;

: add-simple-responder ( name quot -- )
    [
        [ drop ] swap append dup "get" set "post" set
        "responder" set
    ] make-hash add-responder ;

: make-responder ( quot -- responder )
    #! quot has stack effect ( url -- )
    [
        [
            drop "GET method not implemented" httpd-error
        ] "get" set
        [
            drop "POST method not implemented" httpd-error
        ] "post" set
        [
            drop "HEAD method not implemented" httpd-error
        ] "head" set
        [
            drop bad-request
        ] "bad" set
        
        call
    ] make-hash add-responder ;

: vhost ( name -- vhost )
    vhosts get hash [ "default" vhost ] unless* ;

: responder ( name -- responder )
    responders get hash [ "404" responder ] unless* ;

: set-default-responder ( name -- )
    responder "default" responders get set-hash ;

: call-responder ( method argument responder -- )
    over "argument" set [ swap get call ] bind ;

: serve-default-responder ( method url -- )
    "default" responder call-responder ;

: log-responder ( path -- )
    "Calling responder " swap append log-message ;

: trim-/ ( url -- url )
    #! Trim a leading /, if there is one.
    "/" ?head drop ;

: serve-explicit-responder ( method url -- )
    "/" split1 dup [
        swap responder call-responder
    ] [
        ! Just a responder name by itself
        drop "request" get "/" append redirect 2drop
    ] if ;

: serve-responder ( method path host -- )
    #! Responder paths come in two forms:
    #! /foo/bar... - default responder used
    #! /responder/foo/bar - responder foo, argument bar
    vhost [
        dup log-responder trim-/ "responder/" ?head [
            serve-explicit-responder
        ] [
            serve-default-responder
        ] if
    ] bind ;

: no-such-responder ( -- )
    "404 No such responder" httpd-error ;
minor cleanups here and there 2005-04-19 20:28:01 -04:00			`! Copyright (C) 2004, 2005 Slava Pestov.`
			`! See http://factor.sf.net/license.txt for BSD license.`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00			`IN: httpd`
HTTPD updates and minor help fixes 2006-06-15 01:21:16 -04:00			`USING: arrays hashtables html http io kernel math namespaces`
			`parser sequences strings ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
httpd fixes and socket timeout 2005-05-23 19:14:29 -04:00			`! Variables`
			`SYMBOL: vhosts`
			`SYMBOL: responders`

simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00			`: print-header ( alist -- )`
httpd -- added Date and Last-Modified header fields for file-responder, removed url-encode from print-header 2006-08-28 20:36:54 -04:00			`[ swap write ": " write print ] hash-each ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
			`: response ( header msg -- )`
			`"HTTP/1.0 " write print print-header ;`

			`: error-body ( error -- body )`
HTTPD updates and minor help fixes 2006-06-15 01:21:16 -04:00			`<html> <body> <h1> write </h1> </body> </html> ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
			`: error-head ( error -- )`
			`dup log-error`
I/O documentation and code cleanups 2006-01-16 02:48:15 -05:00			`H{ { "Content-Type" "text/html" } } over response ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
			`: httpd-error ( error -- )`
			`#! This must be run from handle-request`
			`error-head`
rename ifte to if 2005-09-24 15:21:17 -04:00			`"head" "method" get = [ drop ] [ terpri error-body ] if ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
			`: bad-request ( -- )`
			`[`
			`! Make httpd-error print a body`
			`"get" "method" set`
			`"400 Bad request" httpd-error`
			`] with-scope ;`

minor tweaks 2005-09-22 16:21:36 -04:00			`: serving-content ( mime -- )`
fix httpd 2006-01-17 10:47:15 -05:00			`"Content-Type" associate`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00			`"200 Document follows" response terpri ;`

minor tweaks 2005-09-22 16:21:36 -04:00			`: serving-html "text/html" serving-content ;`

			`: serving-text "text/plain" serving-content ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
			`: redirect ( to -- )`
fix httpd 2006-01-17 10:47:15 -05:00			`"Location" associate`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00			`"301 Moved Permanently" response terpri ;`

			`: directory-no/ ( -- )`
			`[`
duplex-stream stream-close bugfix 2005-06-23 22:35:41 -04:00			`"request" get % CHAR: / ,`
			`"raw-query" get [ CHAR: ? , % ] when*`
major cleanup 2005-08-25 15:27:38 -04:00			`] "" make redirect ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
httpd fixes 2005-11-29 23:49:59 -05:00			`: query>hash ( query -- hash )`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00			`dup [`
			`"&" split [`
httpd fixes 2005-11-29 23:49:59 -05:00			`"=" split1 [ dup [ url-decode ] when ] 2apply 2array`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00			`] map`
httpd fixes 2005-11-29 23:49:59 -05:00			`] when alist>hash ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
httpd fixes 2005-11-29 23:49:59 -05:00			`: read-post-request ( header -- hash )`
			`"Content-Length" swap hash dup`
httpd: add raw-response variable to httpd 2006-11-18 02:38:58 -05:00			`[ string>number read dup "raw-response" set query>hash ] when ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
Better HTTPD logging, and fix a file-responder bug 2006-02-03 20:00:23 -05:00			`: log-headers ( hash -- )`
			`[`
			`drop { "User-Agent" "X-Forwarded-For" "Host" } member?`
Rename append3 to 3append - updating libs/ 2006-12-10 15:01:52 -05:00			`] hash-subset [ ": " swap 3append log-message ] hash-each ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
			`: prepare-url ( url -- url )`
			`#! This is executed in the with-request namespace.`
			`"?" split1`
httpd fixes 2005-11-29 23:49:59 -05:00			`dup "raw-query" set query>hash "query" set`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00			`dup "request" set ;`

			`: prepare-header ( -- )`
			`read-header dup "header" set`
Better HTTPD logging, and fix a file-responder bug 2006-02-03 20:00:23 -05:00			`dup log-headers`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00			`read-post-request "response" set ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
file responder: redirect if directory url does not end with /, and other changes to httpd 2004-08-29 23:30:54 -04:00			`! Responders are called in a new namespace with these`
			`! variables:`

file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00			`! - method -- one of get, post, or head.`
file responder: redirect if directory url does not end with /, and other changes to httpd 2004-08-29 23:30:54 -04:00			`! - request -- the entire URL requested, including responder`
			`! name`
			`! - raw-query -- raw query string`
httpd fixes 2005-11-29 23:49:59 -05:00			`! - query -- a hashtable of query parameters, eg`
file responder: redirect if directory url does not end with /, and other changes to httpd 2004-08-29 23:30:54 -04:00			`! foo.bar?a=b&c=d becomes`
httpd fixes 2005-11-29 23:49:59 -05:00			`! H{ { "a" "b" } { "c" "d" } }`
			`! - header -- a hashtable of headers from the user's client`
			`! - response -- a hashtable of the POST request response`
httpd: add raw-response variable to httpd 2006-11-18 02:38:58 -05:00			`! - raw-response -- raw POST request response`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
HTTPD updates and minor help fixes 2006-06-15 01:21:16 -04:00			`: query-param ( key -- value ) "query" get hash ;`

more code cleanups; new make-hash idiom 2005-08-22 02:06:32 -04:00			`: add-responder ( responder -- )`
			`#! Add a responder object to the list.`
			`"responder" over hash responders get set-hash ;`

HTTPD updates and minor help fixes 2006-06-15 01:21:16 -04:00			`: add-simple-responder ( name quot -- )`
			`[`
			`[ drop ] swap append dup "get" set "post" set`
			`"responder" set`
			`] make-hash add-responder ;`

more code cleanups; new make-hash idiom 2005-08-22 02:06:32 -04:00			`: make-responder ( quot -- responder )`
fix stack effects/formatting in contrib files 2006-10-05 13:39:13 -04:00			`#! quot has stack effect ( url -- )`
more code cleanups; new make-hash idiom 2005-08-22 02:06:32 -04:00			`[`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00			`[`
			`drop "GET method not implemented" httpd-error`
			`] "get" set`
			`[`
			`drop "POST method not implemented" httpd-error`
			`] "post" set`
command for inserting USE: declarations, cfactor memory management cleanup 2004-08-31 20:31:16 -04:00			`[`
			`drop "HEAD method not implemented" httpd-error`
			`] "head" set`
file-responder improvements, plugin improvements 2004-09-02 16:40:34 -04:00			`[`
			`drop bad-request`
			`] "bad" set`
more code cleanups; new make-hash idiom 2005-08-22 02:06:32 -04:00
			`call`
			`] make-hash add-responder ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
Fix stack effect bug in httpd 2006-12-17 22:15:33 -05:00			`: vhost ( name -- vhost )`
httpd fixes and socket timeout 2005-05-23 19:14:29 -04:00			`vhosts get hash [ "default" vhost ] unless* ;`
slightly more modular loading of subsystems 2005-05-23 01:18:51 -04:00
			`: responder ( name -- responder )`
httpd fixes and socket timeout 2005-05-23 19:14:29 -04:00			`responders get hash [ "404" responder ] unless* ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
httpd responder changes, fix gc race 2004-09-22 23:42:45 -04:00			`: set-default-responder ( name -- )`
httpd fixes and socket timeout 2005-05-23 19:14:29 -04:00			`responder "default" responders get set-hash ;`
httpd responder changes, fix gc race 2004-09-22 23:42:45 -04:00
First import of Factor 0.60 2004-07-16 02:26:21 -04:00			`: call-responder ( method argument responder -- )`
File responder directory listing fixes 2006-01-31 22:43:29 -05:00			`over "argument" set [ swap get call ] bind ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
httpd responder changes, fix gc race 2004-09-22 23:42:45 -04:00			`: serve-default-responder ( method url -- )`
slightly more modular loading of subsystems 2005-05-23 01:18:51 -04:00			`"default" responder call-responder ;`
httpd responder changes, fix gc race 2004-09-22 23:42:45 -04:00
slightly more modular loading of subsystems 2005-05-23 01:18:51 -04:00			`: log-responder ( path -- )`
more cleanups; split up huge gadgets vocabulary 2005-08-31 21:06:13 -04:00			`"Calling responder " swap append log-message ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
			`: trim-/ ( url -- url )`
			`#! Trim a leading /, if there is one.`
more sequence cleanups 2005-05-18 16:26:22 -04:00			`"/" ?head drop ;`
simple HTTP client; with-stream* word; various tweaks and cleanups 2005-05-02 00:18:34 -04:00
httpd responder changes, fix gc race 2004-09-22 23:42:45 -04:00			`: serve-explicit-responder ( method url -- )`
			`"/" split1 dup [`
slightly more modular loading of subsystems 2005-05-23 01:18:51 -04:00			`swap responder call-responder`
httpd responder changes, fix gc race 2004-09-22 23:42:45 -04:00			`] [`
			`! Just a responder name by itself`
Fix stack effect bug in httpd 2006-12-17 22:15:33 -05:00			`drop "request" get "/" append redirect 2drop`
rename ifte to if 2005-09-24 15:21:17 -04:00			`] if ;`
First import of Factor 0.60 2004-07-16 02:26:21 -04:00
slightly more modular loading of subsystems 2005-05-23 01:18:51 -04:00			`: serve-responder ( method path host -- )`
			`#! Responder paths come in two forms:`
			`#! /foo/bar... - default responder used`
httpd responder changes, fix gc race 2004-09-22 23:42:45 -04:00			`#! /responder/foo/bar - responder foo, argument bar`
slightly more modular loading of subsystems 2005-05-23 01:18:51 -04:00			`vhost [`
			`dup log-responder trim-/ "responder/" ?head [`
			`serve-explicit-responder`
			`] [`
			`serve-default-responder`
rename ifte to if 2005-09-24 15:21:17 -04:00			`] if`
slightly more modular loading of subsystems 2005-05-23 01:18:51 -04:00			`] bind ;`
html-tags imported, file responder shows icons 2004-09-02 19:38:05 -04:00
			`: no-such-responder ( -- )`
			`"404 No such responder" httpd-error ;`