Remove obsolete vocab
Slava Pestov
parent
6260cd3e5a
commit
a2aa718cd4
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,225 +0,0 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs hashtables html html.elements splitting
|
||||
http io kernel math math.parser namespaces parser sequences
|
||||
strings io.server vectors assocs.lib logging ;
|
||||
|
||||
IN: http.server.responders
|
||||
|
||||
! Variables
|
||||
SYMBOL: vhosts
|
||||
SYMBOL: responders
|
||||
|
||||
: >header ( value key -- multi-hash )
|
||||
H{ } clone [ insert-at ] keep ;
|
||||
|
||||
: print-header ( alist -- )
|
||||
[ swap write ": " write print ] multi-assoc-each nl ;
|
||||
|
||||
: response ( msg -- ) "HTTP/1.0 " write print ;
|
||||
|
||||
: error-body ( error -- )
|
||||
<html> <body> <h1> write </h1> </body> </html> ;
|
||||
|
||||
: error-head ( error -- )
|
||||
response
|
||||
H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
|
||||
|
||||
: httpd-error ( error -- )
|
||||
#! This must be run from handle-request
|
||||
dup error-head
|
||||
"head" "method" get = [ drop ] [ error-body ] if ;
|
||||
|
||||
\ httpd-error ERROR add-error-logging
|
||||
|
||||
: bad-request ( -- )
|
||||
[
|
||||
! Make httpd-error print a body
|
||||
"get" "method" set
|
||||
"400 Bad request" httpd-error
|
||||
] with-scope ;
|
||||
|
||||
: serving-content ( mime -- )
|
||||
"200 Document follows" response
|
||||
"Content-Type" >header print-header ;
|
||||
|
||||
: serving-html "text/html" serving-content ;
|
||||
|
||||
: serve-html ( quot -- )
|
||||
serving-html with-html-stream ;
|
||||
|
||||
: serving-text "text/plain" serving-content ;
|
||||
|
||||
: redirect ( to response -- )
|
||||
response "Location" >header print-header ;
|
||||
|
||||
: permanent-redirect ( to -- )
|
||||
"301 Moved Permanently" redirect ;
|
||||
|
||||
: temporary-redirect ( to -- )
|
||||
"307 Temporary Redirect" redirect ;
|
||||
|
||||
: directory-no/ ( -- )
|
||||
[
|
||||
"request" get % CHAR: / ,
|
||||
"raw-query" get [ CHAR: ? , % ] when*
|
||||
] "" make permanent-redirect ;
|
||||
|
||||
: query>hash ( query -- hash )
|
||||
dup [
|
||||
"&" split [
|
||||
"=" split1 [ dup [ url-decode ] when ] 2apply 2array
|
||||
] map
|
||||
] when >hashtable ;
|
||||
|
||||
SYMBOL: max-post-request
|
||||
|
||||
1024 256 * max-post-request set-global
|
||||
|
||||
: content-length ( header -- n )
|
||||
"Content-Length" swap at string>number dup [
|
||||
dup max-post-request get > [
|
||||
"Content-Length > max-post-request" throw
|
||||
] when
|
||||
] when ;
|
||||
|
||||
: read-post-request ( header -- str hash )
|
||||
content-length [ read dup query>hash ] [ f f ] if* ;
|
||||
|
||||
LOG: log-headers DEBUG
|
||||
|
||||
: interesting-headers ( assoc -- string )
|
||||
[
|
||||
[
|
||||
drop {
|
||||
"user-agent"
|
||||
"referer"
|
||||
"x-forwarded-for"
|
||||
"host"
|
||||
} member?
|
||||
] assoc-subset [
|
||||
": " swap 3append % "\n" %
|
||||
] multi-assoc-each
|
||||
] "" make ;
|
||||
|
||||
: 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 interesting-headers log-headers
|
||||
read-post-request "response" set "raw-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
|
||||
! - responder-url -- the component of the URL for the responder
|
||||
! - 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 at ;
|
||||
|
||||
: header-param ( key -- value )
|
||||
"header" get peek-at ;
|
||||
|
||||
: host ( -- string )
|
||||
#! The host the current responder was called from.
|
||||
"Host" header-param ":" split1 drop ;
|
||||
|
||||
: add-responder ( responder -- )
|
||||
#! Add a responder object to the list.
|
||||
"responder" over at responders get set-at ;
|
||||
|
||||
: make-responder ( quot -- )
|
||||
#! 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
|
||||
] H{ } make-assoc add-responder ;
|
||||
|
||||
: add-simple-responder ( name quot -- )
|
||||
[
|
||||
[ drop ] swap append dup "get" set "post" set
|
||||
"responder" set
|
||||
] make-responder ;
|
||||
|
||||
: vhost ( name -- vhost )
|
||||
vhosts get at [ "default" vhost ] unless* ;
|
||||
|
||||
: responder ( name -- responder )
|
||||
responders get at [ "404" responder ] unless* ;
|
||||
|
||||
: set-default-responder ( name -- )
|
||||
responder "default" responders get set-at ;
|
||||
|
||||
: call-responder ( method argument responder -- )
|
||||
over "argument" set [ swap get with-scope ] bind ;
|
||||
|
||||
: serve-default-responder ( method url -- )
|
||||
"/" "responder-url" set
|
||||
"default" responder call-responder ;
|
||||
|
||||
: trim-/ ( url -- url )
|
||||
#! Trim a leading /, if there is one.
|
||||
"/" ?head drop ;
|
||||
|
||||
: serve-explicit-responder ( method url -- )
|
||||
"/" split1
|
||||
"/responder/" pick "/" 3append "responder-url" set
|
||||
dup [
|
||||
swap responder call-responder
|
||||
] [
|
||||
! Just a responder name by itself
|
||||
drop "request" get "/" append permanent-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 [
|
||||
trim-/ "responder/" ?head [
|
||||
serve-explicit-responder
|
||||
] [
|
||||
serve-default-responder
|
||||
] if
|
||||
] bind ;
|
||||
|
||||
\ serve-responder DEBUG add-input-logging
|
||||
|
||||
: no-such-responder ( -- )
|
||||
"404 No such responder" httpd-error ;
|
||||
|
||||
! create a responders hash if it doesn't already exist
|
||||
global [
|
||||
responders [ H{ } assoc-like ] change
|
||||
|
||||
! 404 error message pages are served by this guy
|
||||
"404" [ no-such-responder ] add-simple-responder
|
||||
|
||||
H{ } clone "default" associate vhosts set
|
||||
] bind
|
||||
Loading…
Reference in New Issue