Working on new HTTP server
Slava Pestov
parent
20bbb4b5ae
commit
6260cd3e5a
|
|
@ -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 ? )
|
||||
at* dup [ >r peek r> ] when ;
|
||||
: peek-at* ( assoc key -- obj ? )
|
||||
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 )
|
||||
|
|
|
|||
|
|
@ -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/" %
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ "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" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
|
||||
[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] 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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
#! Extract the host name and port number from an HTTP URL.
|
||||
":" 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
|
||||
: parse-url ( url -- resource host port )
|
||||
"http://" ?head [ "Only http:// supported" throw ] unless
|
||||
"/" split1 [ "/" swap append ] [ "/" ] if*
|
||||
>r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
|
||||
swap parse-host ;
|
||||
|
||||
: parse-response ( line -- code )
|
||||
"HTTP/" ?head [ " " split1 nip ] when
|
||||
" " split1 drop string>number [
|
||||
"Premature end of stream" throw
|
||||
] unless* ;
|
||||
<PRIVATE
|
||||
|
||||
: read-response ( -- code header )
|
||||
#! After sending a GET or POST we read a response line and
|
||||
#! header.
|
||||
flush readln parse-response read-header ;
|
||||
: store-path ( request path -- request )
|
||||
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
|
||||
|
||||
: 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 -- )
|
||||
write bl write " HTTP/1.0" write crlf
|
||||
"Host: " write write crlf ;
|
||||
DEFER: (http-request)
|
||||
|
||||
: get-request ( host resource -- )
|
||||
"GET" http-request crlf ;
|
||||
: absolute-redirect ( url -- request )
|
||||
"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 )
|
||||
#! Should this support Location: headers that are
|
||||
#! relative URLs?
|
||||
pick 100 /i 3 = [
|
||||
dispose "location" swap peek-at nip http-get-stream
|
||||
] when ;
|
||||
: do-redirect ( response -- response stream )
|
||||
dup response-code 300 399 between? [
|
||||
header>> "location" peek-at
|
||||
dup "http://" head? [
|
||||
absolute-redirect
|
||||
] [
|
||||
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 )
|
||||
#! Opens a stream for reading from an HTTP URL.
|
||||
parse-url over parse-host <inet> <client> [
|
||||
[ [ get-request read-response ] with-stream* ] keep
|
||||
default-timeout
|
||||
] [ ] [ dispose ] cleanup do-redirect ;
|
||||
PRIVATE>
|
||||
|
||||
: http-request ( url request -- response stream )
|
||||
[
|
||||
request-with-url
|
||||
[
|
||||
(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 )
|
||||
nip swap success?
|
||||
: check-response ( response stream -- stream )
|
||||
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
|
||||
r> <file-writer> stream-copy ;
|
||||
swap http-get-stream check-response
|
||||
[ swap <file-writer> stream-copy ] with-disposal ;
|
||||
|
||||
: download ( url -- )
|
||||
dup download-name download-to ;
|
||||
|
||||
: post-request ( content-type content host resource -- )
|
||||
#! Note: It is up to the caller to url encode the content if
|
||||
#! it is required according to the content-type.
|
||||
"POST" http-request [
|
||||
"Content-Length: " write length number>string write crlf
|
||||
"Content-Type: " write url-encode write crlf
|
||||
crlf
|
||||
] keep write ;
|
||||
: <post-request> ( content-type content -- request )
|
||||
request construct-empty
|
||||
"POST" >>method
|
||||
swap >>post-data
|
||||
swap >>post-data-type ;
|
||||
|
||||
: http-post ( content-type content url -- code headers string )
|
||||
#! Make a POST request. The content is URL encoded for you.
|
||||
parse-url over parse-host <inet> <client> [
|
||||
post-request flush read-response stdio get contents
|
||||
] with-stream ;
|
||||
: http-post ( content-type content url -- response string )
|
||||
#! The content is URL encoded for you.
|
||||
-rot url-encode <post-request> http-request contents ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
sequences strings splitting ascii io.encodings.utf8 assocs.lib
|
||||
namespaces unicode.case ;
|
||||
USING: hashtables io io.streams.string kernel math namespaces
|
||||
math.parser assocs sequences strings splitting ascii
|
||||
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) ] H{ } make-assoc ;
|
||||
: read-header ( -- multi-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 assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
CHAR: ? rot member? "&" "?" ? %
|
||||
hash>query %
|
||||
] if
|
||||
] "" make ;
|
||||
dup host>> [
|
||||
"http://" write
|
||||
dup host>> url-encode write
|
||||
":" write
|
||||
dup port>> number>string write
|
||||
] when
|
||||
"/" write
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -1,39 +1,45 @@
|
|||
USING: webapps.file http.server.responders http
|
||||
http.server namespaces io tools.test strings io.server
|
||||
logging ;
|
||||
USING: http.server tools.test kernel namespaces accessors
|
||||
new-slots assocs.lib io http math sequences ;
|
||||
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" ]
|
||||
[ "http://www.jedit.org/index.html" url>path ] unit-test
|
||||
M: mock-responder do-responder
|
||||
2nip
|
||||
path>> on
|
||||
[ "Hello world" print ]
|
||||
"text/plain" <content> ;
|
||||
|
||||
[ "foo/bar" ]
|
||||
[ "http://www.jedit.org/foo/bar" url>path ] unit-test
|
||||
: check-dispatch ( tag path -- ? )
|
||||
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
|
||||
|
||||
[ "" ]
|
||||
[ "http://www.jedit.org" url>path ] unit-test
|
||||
[ t ] [ "foo" "foo" check-dispatch ] 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" ]
|
||||
[ "foobar" secure-path ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "foobar/../baz" secure-path ] unit-test
|
||||
|
||||
[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test
|
||||
[ ] [ f [ "POO" parse-request ] with-logging ] unit-test
|
||||
|
||||
[ 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
|
||||
[ t ] [
|
||||
<request>
|
||||
"baz" >>path
|
||||
"baz" default-host get call-responder
|
||||
dup code>> 300 399 between? >r
|
||||
header>> "location" peek-at "baz/" tail? r> and
|
||||
nip
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
|
|
|||
|
|
@ -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
|
||||
io.server logging calendar ;
|
||||
|
||||
threads http sequences prettyprint io.server logging calendar
|
||||
new-slots html.elements accessors math.parser combinators.lib ;
|
||||
IN: http.server
|
||||
|
||||
: (url>path) ( uri -- path )
|
||||
url-decode "http://" ?head [
|
||||
"/" split1 dup "" ? nip
|
||||
] when ;
|
||||
TUPLE: responder path directory ;
|
||||
|
||||
: url>path ( uri -- path )
|
||||
"?" split1 dup [
|
||||
>r (url>path) "?" r> 3append
|
||||
] [
|
||||
drop (url>path)
|
||||
] if ;
|
||||
: <responder> ( path -- responder )
|
||||
"/" ?tail responder construct-boa ;
|
||||
|
||||
: secure-path ( path -- path )
|
||||
".." over subseq? [ drop f ] when ;
|
||||
GENERIC: do-responder ( request path responder -- quot response )
|
||||
|
||||
: request-method ( cmd -- method )
|
||||
H{
|
||||
{ "GET" "get" }
|
||||
{ "POST" "post" }
|
||||
{ "HEAD" "head" }
|
||||
} at "bad" or ;
|
||||
TUPLE: trivial-responder quot response ;
|
||||
|
||||
: (handle-request) ( arg cmd -- method path host )
|
||||
request-method dup "method" set swap
|
||||
prepare-url prepare-header host ;
|
||||
: <trivial-responder> ( quot response -- responder )
|
||||
trivial-responder construct-boa
|
||||
"" <responder> over set-delegate ;
|
||||
|
||||
: handle-request ( arg cmd -- )
|
||||
[ (handle-request) serve-responder ] with-scope ;
|
||||
M: trivial-responder do-responder
|
||||
2nip dup quot>> swap response>> ;
|
||||
|
||||
: parse-request ( request -- )
|
||||
" " split1 dup [
|
||||
" HTTP" split1 drop url>path secure-path dup [
|
||||
swap handle-request
|
||||
] [
|
||||
2drop bad-request
|
||||
] if
|
||||
] [
|
||||
2drop bad-request
|
||||
] if ;
|
||||
: trivial-response-body ( code message -- )
|
||||
<html>
|
||||
<body>
|
||||
<h1> swap number>string write bl write </h1>
|
||||
</body>
|
||||
</html> ;
|
||||
|
||||
\ 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
|
||||
readln [ parse-request ] when*
|
||||
default-timeout
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue