diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 182f04a367..88095759e6 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -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 ) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 11ff697049..f10094f07b 100755 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -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/" % diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index d2fb719acd..5e407657a8 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -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" + + request-with-url + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 99ba045019..8b74b6dc72 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -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* ; +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>> 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 [ - [ [ 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 ; + +: ( -- request ) + request construct-empty + "GET" >>method ; + +: http-get-stream ( url -- response stream ) + 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> stream-copy ; + swap http-get-stream check-response + [ swap 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 ; +: ( 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 [ - 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 http-request contents ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor old mode 100644 new mode 100755 index 5146502644..9fa593053c --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -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 diff --git a/extra/http/http.factor b/extra/http/http.factor index 5c4dae94c7..4c2834b7ca 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 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 ) + + 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 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 ) + + 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 ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index 18edd94f12..a67d21a640 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -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 +: ( path -- 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" ; -[ "foo/bar" ] -[ "http://www.jedit.org/foo/bar" url>path ] unit-test +: check-dispatch ( tag path -- ? ) + over off + swap default-host get call-responder + write-response call get ; -[ "" ] -[ "http://www.jedit.org/" url>path ] unit-test +[ + "" + "foo" add-responder + "bar" add-responder + "baz/" + "123" add-responder + "default" >>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 ] [ + + "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 diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index a2f5c3474b..e06ae6a95c 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -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 ; +: ( 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 ; +: ( quot response -- responder ) + trivial-responder construct-boa + "" 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 -- ) + + +

swap number>string write bl write

+ + ; -\ parse-request NOTICE add-input-logging +: ( code message -- quot response ) + [ [ trivial-response-body ] 2curry ] 2keep + "text/html" set-content-type + swap >>message + swap >>code ; + +: <404> ( -- quot response ) + 404 "Not Found" ; + +: ( to code message -- quot response ) + + rot "location" set-response-header ; + +: ( to -- quot response ) + 301 "Moved Permanently" ; + +: ( to -- quot response ) + 307 "Temporary Redirect" ; + +: ( content-type -- 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 ; + +: ( -- responder ) + "" no-/-responder construct-delegate ; + + 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> 404-responder set-global + +M: dispatcher do-responder + find-responder call-responder ; + +: ( path -- dispatcher ) + + 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