2005-04-19 20:28:01 -04:00
|
|
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
2005-05-02 00:18:34 -04:00
|
|
|
IN: httpd
|
2005-08-31 21:06:13 -04:00
|
|
|
USING: hashtables http kernel lists math namespaces parser
|
|
|
|
|
sequences io strings ;
|
2005-05-02 00:18:34 -04:00
|
|
|
|
2005-05-23 19:14:29 -04:00
|
|
|
! Variables
|
|
|
|
|
SYMBOL: vhosts
|
|
|
|
|
SYMBOL: responders
|
|
|
|
|
|
2005-05-02 00:18:34 -04:00
|
|
|
: print-header ( alist -- )
|
|
|
|
|
[ unswons write ": " write url-encode print ] each ;
|
|
|
|
|
|
|
|
|
|
: response ( header msg -- )
|
|
|
|
|
"HTTP/1.0 " write print print-header ;
|
|
|
|
|
|
|
|
|
|
: error-body ( error -- body )
|
2005-05-18 16:26:22 -04:00
|
|
|
"<html><body><h1>" swap "</h1></body></html>" append3 print ;
|
2005-05-02 00:18:34 -04:00
|
|
|
|
|
|
|
|
: error-head ( error -- )
|
|
|
|
|
dup log-error
|
|
|
|
|
[ [[ "Content-Type" "text/html" ]] ] over response ;
|
|
|
|
|
|
|
|
|
|
: httpd-error ( error -- )
|
|
|
|
|
#! This must be run from handle-request
|
|
|
|
|
error-head
|
|
|
|
|
"head" "method" get = [ terpri error-body ] unless ;
|
|
|
|
|
|
|
|
|
|
: bad-request ( -- )
|
|
|
|
|
[
|
|
|
|
|
! Make httpd-error print a body
|
|
|
|
|
"get" "method" set
|
|
|
|
|
"400 Bad request" httpd-error
|
|
|
|
|
] with-scope ;
|
|
|
|
|
|
|
|
|
|
: serving-html ( -- )
|
|
|
|
|
[ [[ "Content-Type" "text/html" ]] ]
|
|
|
|
|
"200 Document follows" response terpri ;
|
|
|
|
|
|
|
|
|
|
: serving-text ( -- )
|
|
|
|
|
[ [[ "Content-Type" "text/plain" ]] ]
|
|
|
|
|
"200 Document follows" response terpri ;
|
|
|
|
|
|
|
|
|
|
: redirect ( to -- )
|
|
|
|
|
"Location" swons unit
|
|
|
|
|
"301 Moved Permanently" response terpri ;
|
|
|
|
|
|
|
|
|
|
: directory-no/ ( -- )
|
|
|
|
|
[
|
2005-06-23 22:35:41 -04:00
|
|
|
"request" get % CHAR: / ,
|
|
|
|
|
"raw-query" get [ CHAR: ? , % ] when*
|
2005-08-25 15:27:38 -04:00
|
|
|
] "" make redirect ;
|
2005-05-02 00:18:34 -04:00
|
|
|
|
|
|
|
|
: query>alist ( query -- alist )
|
|
|
|
|
dup [
|
|
|
|
|
"&" split [
|
|
|
|
|
"=" split1
|
|
|
|
|
dup [ url-decode ] when swap
|
|
|
|
|
dup [ url-decode ] when swap cons
|
|
|
|
|
] map
|
|
|
|
|
] when ;
|
|
|
|
|
|
|
|
|
|
: read-post-request ( header -- alist )
|
2005-07-31 23:38:33 -04:00
|
|
|
"Content-Length" swap assoc dup
|
2005-08-21 20:50:14 -04:00
|
|
|
[ string>number read query>alist ] when ;
|
2005-05-02 00:18:34 -04:00
|
|
|
|
|
|
|
|
: log-user-agent ( alist -- )
|
|
|
|
|
"User-Agent" swap assoc* [
|
2005-08-31 21:06:13 -04:00
|
|
|
unswons [ % ": " % % ] "" make log-message
|
2005-05-02 00:18:34 -04:00
|
|
|
] when* ;
|
|
|
|
|
|
|
|
|
|
: prepare-url ( url -- url )
|
|
|
|
|
#! This is executed in the with-request namespace.
|
|
|
|
|
"?" split1
|
|
|
|
|
dup "raw-query" set query>alist "query" set
|
|
|
|
|
dup "request" set ;
|
|
|
|
|
|
|
|
|
|
: prepare-header ( -- )
|
|
|
|
|
read-header dup "header" set
|
|
|
|
|
dup log-user-agent
|
|
|
|
|
read-post-request "response" set ;
|
2004-07-16 02:26:21 -04:00
|
|
|
|
2004-08-29 23:30:54 -04:00
|
|
|
! Responders are called in a new namespace with these
|
|
|
|
|
! variables:
|
|
|
|
|
|
2004-09-02 16:40:34 -04:00
|
|
|
! - method -- one of get, post, or head.
|
2004-08-29 23:30:54 -04:00
|
|
|
! - request -- the entire URL requested, including responder
|
|
|
|
|
! name
|
|
|
|
|
! - raw-query -- raw query string
|
|
|
|
|
! - query -- an alist of query parameters, eg
|
|
|
|
|
! foo.bar?a=b&c=d becomes
|
2005-01-13 19:49:47 -05:00
|
|
|
! [ [[ "a" "b" ]] [[ "c" "d" ]] ]
|
2004-08-29 23:30:54 -04:00
|
|
|
! - header -- an alist of headers from the user's client
|
|
|
|
|
! - response -- an alist of the POST request response
|
2004-07-16 02:26:21 -04:00
|
|
|
|
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 ;
|
|
|
|
|
|
|
|
|
|
: make-responder ( quot -- responder )
|
|
|
|
|
[
|
2004-08-17 20:44:57 -04:00
|
|
|
( url -- )
|
2004-07-16 02:26:21 -04:00
|
|
|
[
|
|
|
|
|
drop "GET method not implemented" httpd-error
|
|
|
|
|
] "get" set
|
2004-08-17 20:44:57 -04:00
|
|
|
( url -- )
|
2004-07-16 02:26:21 -04:00
|
|
|
[
|
|
|
|
|
drop "POST method not implemented" httpd-error
|
|
|
|
|
] "post" set
|
2004-08-31 20:31:16 -04:00
|
|
|
( url -- )
|
|
|
|
|
[
|
|
|
|
|
drop "HEAD method not implemented" httpd-error
|
|
|
|
|
] "head" set
|
2004-09-02 16:40:34 -04:00
|
|
|
( url -- )
|
|
|
|
|
[
|
|
|
|
|
drop bad-request
|
|
|
|
|
] "bad" set
|
2005-08-22 02:06:32 -04:00
|
|
|
|
|
|
|
|
call
|
|
|
|
|
] make-hash add-responder ;
|
2004-07-16 02:26:21 -04:00
|
|
|
|
2005-05-23 01:18:51 -04:00
|
|
|
: vhost ( name -- responder )
|
2005-05-23 19:14:29 -04:00
|
|
|
vhosts get hash [ "default" vhost ] unless* ;
|
2005-05-23 01:18:51 -04:00
|
|
|
|
|
|
|
|
: responder ( name -- responder )
|
2005-05-23 19:14:29 -04:00
|
|
|
responders get hash [ "404" responder ] unless* ;
|
2004-07-16 02:26:21 -04:00
|
|
|
|
2004-09-22 23:42:45 -04:00
|
|
|
: set-default-responder ( name -- )
|
2005-05-23 19:14:29 -04:00
|
|
|
responder "default" responders get set-hash ;
|
2004-09-22 23:42:45 -04:00
|
|
|
|
2004-07-16 02:26:21 -04:00
|
|
|
: responder-argument ( argument -- argument )
|
2005-04-19 20:28:01 -04:00
|
|
|
dup empty? [ drop "default-argument" get ] when ;
|
2004-07-16 02:26:21 -04:00
|
|
|
|
|
|
|
|
: call-responder ( method argument responder -- )
|
2004-08-29 23:30:54 -04:00
|
|
|
[ responder-argument swap get call ] bind ;
|
2004-07-16 02:26:21 -04:00
|
|
|
|
2004-09-22 23:42:45 -04:00
|
|
|
: serve-default-responder ( method url -- )
|
2005-05-23 01:18:51 -04:00
|
|
|
"default" responder call-responder ;
|
2004-09-22 23:42:45 -04:00
|
|
|
|
2005-05-23 01:18:51 -04:00
|
|
|
: log-responder ( path -- )
|
2005-08-31 21:06:13 -04:00
|
|
|
"Calling responder " swap append log-message ;
|
2005-05-02 00:18:34 -04:00
|
|
|
|
|
|
|
|
: trim-/ ( url -- url )
|
|
|
|
|
#! Trim a leading /, if there is one.
|
2005-05-18 16:26:22 -04:00
|
|
|
"/" ?head drop ;
|
2005-05-02 00:18:34 -04:00
|
|
|
|
2004-09-22 23:42:45 -04:00
|
|
|
: serve-explicit-responder ( method url -- )
|
|
|
|
|
"/" split1 dup [
|
2005-05-23 01:18:51 -04:00
|
|
|
swap responder call-responder
|
2004-09-22 23:42:45 -04:00
|
|
|
] [
|
|
|
|
|
! Just a responder name by itself
|
2005-05-18 16:26:22 -04:00
|
|
|
drop "request" get "/" append redirect drop
|
2004-09-22 23:42:45 -04:00
|
|
|
] ifte ;
|
2004-07-16 02:26:21 -04:00
|
|
|
|
2005-05-23 01:18:51 -04:00
|
|
|
: serve-responder ( method path host -- )
|
|
|
|
|
#! Responder paths come in two forms:
|
|
|
|
|
#! /foo/bar... - default responder used
|
2004-09-22 23:42:45 -04:00
|
|
|
#! /responder/foo/bar - responder foo, argument bar
|
2005-05-23 01:18:51 -04:00
|
|
|
vhost [
|
|
|
|
|
dup log-responder trim-/ "responder/" ?head [
|
|
|
|
|
serve-explicit-responder
|
|
|
|
|
] [
|
|
|
|
|
serve-default-responder
|
|
|
|
|
] ifte
|
|
|
|
|
] bind ;
|
2004-09-02 19:38:05 -04:00
|
|
|
|
|
|
|
|
: no-such-responder ( -- )
|
|
|
|
|
"404 No such responder" httpd-error ;
|
