diff --git a/extra/http.good/authors.txt b/extra/http.good/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/extra/http.good/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http.good/basic-authentication/authors.txt b/extra/http.good/basic-authentication/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/extra/http.good/basic-authentication/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/http.good/basic-authentication/basic-authentication-docs.factor b/extra/http.good/basic-authentication/basic-authentication-docs.factor deleted file mode 100644 index 68d6e6bf1d..0000000000 --- a/extra/http.good/basic-authentication/basic-authentication-docs.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax crypto.sha2 ; -IN: http.basic-authentication - -HELP: realms -{ $description - "A hashtable mapping a basic authentication realm (a string) " - "to either a quotation or a hashtable. The quotation has " - "stack effect ( username sha-256-string -- bool ). It " - "is expected to perform the user authentication when called." $nl - "If the realm maps to a hashtable then the hashtable should be a " - "mapping of usernames to sha-256 hashed passwords." $nl - "If the 'realms' variable does not exist in the current scope then " - "authentication will always fail." } -{ $see-also add-realm with-basic-authentication } ; - -HELP: add-realm -{ $values - { "data" "a quotation or a hashtable" } { "name" "a string" } } -{ $description - "Adds the authentication data to the " { $link realms } ". 'data' can be " - "a quotation with stack effect ( username sha-256-string -- bool ) or " - "a hashtable mapping username strings to sha-256-string passwords." } -{ $examples - { $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" } - { $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" } -} -{ $see-also with-basic-authentication realms } ; - -HELP: with-basic-authentication -{ $values - { "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } } -{ $description - "Checks if the HTTP request has the correct authorisation headers " - "for basic authentication within the named realm. If the headers " - "are not present then a '401' HTTP response results from the " - "request, otherwise the quotation is called." } -{ $examples -{ $code "\"my-realm\" [\n serving-html \"Success!\" write\n] with-basic-authentication" } } -{ $see-also add-realm realms } - ; - -ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication" -"The Basic Authentication system provides a simple browser based " -"authentication method to web applications. When the browser requests " -"a resource protected with basic authentication the server responds with " -"a '401' response code which means the user is unauthorized." -$nl -"When the browser receives this it prompts the user for a username and " -"password. This is sent back to the server in a special HTTP header. The " -"server then checks this against its authentication information and either " -"accepts or rejects the users request." -$nl -"Authentication is split up into " { $link realms } ". Each realm can have " -"a different database of username and password information. A responder can " -"require basic authentication by using the " { $link with-basic-authentication } " word." -$nl -"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "." -$nl -"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word." -$nl -"Note that Basic Authentication itself is insecure in that it " -"sends the username and password as clear text (although it is " -"base64 encoded this is not much help). To prevent eavesdropping " -"it is best to use Basic Authentication with SSL." ; - -IN: http.basic-authentication -ABOUT: { "http-authentication" "basic-authentication" } diff --git a/extra/http.good/basic-authentication/basic-authentication-tests.factor b/extra/http.good/basic-authentication/basic-authentication-tests.factor deleted file mode 100644 index 318123b0b4..0000000000 --- a/extra/http.good/basic-authentication/basic-authentication-tests.factor +++ /dev/null @@ -1,66 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel crypto.sha2 http.basic-authentication tools.test - namespaces base64 sequences ; - -{ t } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ t } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "xadmin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - [ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm - "test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - f realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test - -{ f } [ - [ - H{ } clone realms set - "test-realm" "Basic " "admin:password" >base64 append authorization-ok? - ] with-scope -] unit-test diff --git a/extra/http.good/basic-authentication/basic-authentication.factor b/extra/http.good/basic-authentication/basic-authentication.factor deleted file mode 100644 index e15ba9db16..0000000000 --- a/extra/http.good/basic-authentication/basic-authentication.factor +++ /dev/null @@ -1,65 +0,0 @@ -! Copyright (c) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel base64 http.server crypto.sha2 namespaces assocs - quotations hashtables combinators splitting sequences - http.server.responders io html.elements ; -IN: http.basic-authentication - -! 'realms' is a hashtable mapping a realm (a string) to -! either a quotation or a hashtable. The quotation -! has stack effect ( username sha-256-string -- bool ). -! It should perform the user authentication. 'sha-256-string' -! is the plain text password provided by the user passed through -! 'string>sha-256-string'. If 'realms' maps to a hashtable then -! it is a mapping of usernames to sha-256 hashed passwords. -! -! 'realms' can be set on a per vhost basis in the vhosts -! table. -! -! If there are no realms then authentication fails. -SYMBOL: realms - -: add-realm ( data name -- ) - #! Add the named realm to the realms table. - #! 'data' should be a hashtable or a quotation. - realms get [ H{ } clone dup realms set ] unless* - set-at ; - -: user-authorized? ( username password realm -- bool ) - realms get dup [ - at { - { [ dup quotation? ] [ call ] } - { [ dup hashtable? ] [ swapd at = ] } - { [ t ] [ 3drop f ] } - } cond - ] [ - 3drop drop f - ] if ; - -: authorization-ok? ( realm header -- bool ) - #! Given the realm and the 'Authorization' header, - #! authenticate the user. - dup [ - " " split dup first "Basic" = [ - second base64> ":" split first2 string>sha-256-string rot - user-authorized? - ] [ - 2drop f - ] if - ] [ - 2drop f - ] if ; - -: authentication-error ( realm -- ) - "401 Unauthorized" response - "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header - - "Username or Password is invalid" write - ; - -: with-basic-authentication ( realm quot -- ) - #! Check if the user is authenticated in the given realm - #! to run the specified quotation. If not, use Basic - #! Authentication to ask for authorization details. - over "Authorization" header-param authorization-ok? - [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http.good/basic-authentication/summary.txt b/extra/http.good/basic-authentication/summary.txt deleted file mode 100644 index 60cef7e630..0000000000 --- a/extra/http.good/basic-authentication/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP Basic Authentication implementation diff --git a/extra/http.good/basic-authentication/tags.txt b/extra/http.good/basic-authentication/tags.txt deleted file mode 100644 index c0772185a0..0000000000 --- a/extra/http.good/basic-authentication/tags.txt +++ /dev/null @@ -1 +0,0 @@ -web diff --git a/extra/http.good/client/authors.txt b/extra/http.good/client/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/extra/http.good/client/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http.good/client/client-tests.factor b/extra/http.good/client/client-tests.factor deleted file mode 100755 index 5e407657a8..0000000000 --- a/extra/http.good/client/client-tests.factor +++ /dev/null @@ -1,26 +0,0 @@ -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 -[ "/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.good/client/client.factor b/extra/http.good/client/client.factor deleted file mode 100755 index 8b74b6dc72..0000000000 --- a/extra/http.good/client/client.factor +++ /dev/null @@ -1,96 +0,0 @@ -! Copyright (C) 2005, 2008 Slava Pestov. -! 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 vectors hashtables -accessors ; -IN: http.client - -: parse-url ( url -- resource host port ) - "http://" ?head [ "Only http:// supported" throw ] unless - "/" split1 [ "/" swap append ] [ "/" ] if* - swap parse-host ; - -r >>path r> dup [ query>assoc ] when >>query ; - -! 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 ; - -DEFER: (http-request) - -: absolute-redirect ( url -- request ) - "request" get request-with-url ; - -: relative-redirect ( path -- request ) - "request" get swap store-path ; - -: 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 ; - -: (http-request) ( request -- response stream ) - dup host>> over port>> stdio set - write-request flush read-response - 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 ( response stream -- stream ) - swap code>> success? - [ dispose "HTTP download failed" throw ] unless ; - -: http-get ( url -- string ) - http-get-stream check-response contents ; - -: download-name ( url -- name ) - file-name "?" split1 drop "/" ?tail drop ; - -: download-to ( url file -- ) - #! Downloads the contents of a URL to a file. - swap http-get-stream check-response - [ swap stream-copy ] with-disposal ; - -: download ( url -- ) - dup download-name download-to ; - -: ( content-type content -- request ) - request construct-empty - "POST" >>method - swap >>post-data - swap >>post-data-type ; - -: 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.good/client/summary.txt b/extra/http.good/client/summary.txt deleted file mode 100644 index 5609c916c4..0000000000 --- a/extra/http.good/client/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP client diff --git a/extra/http.good/client/tags.txt b/extra/http.good/client/tags.txt deleted file mode 100644 index 93e65ae758..0000000000 --- a/extra/http.good/client/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -web -network diff --git a/extra/http.good/http-tests.factor b/extra/http.good/http-tests.factor deleted file mode 100755 index 9fa593053c..0000000000 --- a/extra/http.good/http-tests.factor +++ /dev/null @@ -1,115 +0,0 @@ -USING: http tools.test multiline tuple-syntax -io.streams.string kernel arrays splitting sequences ; -IN: temporary - -[ "hello%20world" ] [ "hello world" url-encode ] unit-test -[ "hello world" ] [ "hello%20world" url-decode ] unit-test -[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test -[ "" ] [ "%XX%XX%XX" url-decode ] unit-test -[ "" ] [ "%XX%XX%X" url-decode ] unit-test - -[ "hello world" ] [ "hello+world" url-decode ] unit-test -[ "hello world" ] [ "hello%20world" url-decode ] unit-test -[ " ! " ] [ "%20%21%20" url-decode ] unit-test -[ "hello world" ] [ "hello world%" url-decode ] unit-test -[ "hello world" ] [ "hello world%x" url-decode ] unit-test -[ "hello%20world" ] [ "hello world" url-encode ] unit-test -[ "%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.good/http.factor b/extra/http.good/http.factor deleted file mode 100755 index 4c2834b7ca..0000000000 --- a/extra/http.good/http.factor +++ /dev/null @@ -1,277 +0,0 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -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-line ( -- ) - readln dup - empty? [ drop ] [ header-line read-header-line ] if ; - -: 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 - #! URL-encoding? - dup letter? - over LETTER? or - over digit? or - swap "/_-." member? or ; foldable - -: push-utf8 ( ch -- ) - 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; - -: url-encode ( str -- str ) - [ [ - dup url-quotable? [ , ] [ push-utf8 ] if - ] each ] "" make ; - -: url-decode-hex ( index str -- ) - 2dup length 2 - >= [ - 2drop - ] [ - >r 1+ dup 2 + r> subseq hex> [ , ] when* - ] if ; - -: url-decode-% ( index str -- index str ) - 2dup url-decode-hex >r 3 + r> ; - -: url-decode-+-or-other ( index str ch -- index str ) - dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ; - -: url-decode-iter ( index str -- ) - 2dup length >= [ - 2drop - ] [ - 2dup nth dup CHAR: % = [ - drop url-decode-% - ] [ - url-decode-+-or-other - ] if url-decode-iter - ] if ; - -: url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make decode-utf8 ; - -: 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 ; - -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 ) - [ - 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.good/mime/authors.txt b/extra/http.good/mime/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/http.good/mime/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http.good/mime/mime.factor b/extra/http.good/mime/mime.factor deleted file mode 100644 index 3365127d87..0000000000 --- a/extra/http.good/mime/mime.factor +++ /dev/null @@ -1,34 +0,0 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io assocs kernel sequences math namespaces splitting ; - -IN: http.mime - -: file-extension ( filename -- extension ) - "." split dup length 1 <= [ drop f ] [ peek ] if ; - -: mime-type ( filename -- mime-type ) - file-extension "mime-types" get at "application/octet-stream" or ; - -H{ - { "html" "text/html" } - { "txt" "text/plain" } - { "xml" "text/xml" } - { "css" "text/css" } - - { "gif" "image/gif" } - { "png" "image/png" } - { "jpg" "image/jpeg" } - { "jpeg" "image/jpeg" } - - { "jar" "application/octet-stream" } - { "zip" "application/octet-stream" } - { "tgz" "application/octet-stream" } - { "tar.gz" "application/octet-stream" } - { "gz" "application/octet-stream" } - - { "pdf" "application/pdf" } - - { "factor" "text/plain" } - { "fhtml" "application/x-factor-server-page" } -} "mime-types" set-global diff --git a/extra/http.good/server/authors.txt b/extra/http.good/server/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/http.good/server/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/http.good/server/server-tests.factor b/extra/http.good/server/server-tests.factor deleted file mode 100755 index a67d21a640..0000000000 --- a/extra/http.good/server/server-tests.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: http.server tools.test kernel namespaces accessors -new-slots assocs.lib io http math sequences ; -IN: temporary - -TUPLE: mock-responder ; - -: ( path -- responder ) - mock-responder construct-delegate ; - -M: mock-responder do-responder - 2nip - path>> on - [ "Hello world" print ] - "text/plain" ; - -: check-dispatch ( tag path -- ? ) - over off - swap default-host get call-responder - write-response call get ; - -[ - "" - "foo" add-responder - "bar" add-responder - "baz/" - "123" add-responder - "default" >>default - add-responder - default-host set - - [ 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 - - [ 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.good/server/server.factor b/extra/http.good/server/server.factor deleted file mode 100755 index e06ae6a95c..0000000000 --- a/extra/http.good/server/server.factor +++ /dev/null @@ -1,131 +0,0 @@ -! 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 sequences prettyprint io.server logging calendar -new-slots html.elements accessors math.parser combinators.lib ; -IN: http.server - -TUPLE: responder path directory ; - -: ( path -- responder ) - "/" ?tail responder construct-boa ; - -GENERIC: do-responder ( request path responder -- quot response ) - -TUPLE: trivial-responder quot response ; - -: ( quot response -- responder ) - trivial-responder construct-boa - "" over set-delegate ; - -M: trivial-responder do-responder - 2nip dup quot>> swap response>> ; - -: trivial-response-body ( code message -- ) - - -

swap number>string write bl write

- - ; - -: ( 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" [ - default-timeout - read-request dup log-request handle-request - ] with-server ; - -: httpd-main ( -- ) 8888 httpd ; - -MAIN: httpd-main diff --git a/extra/http.good/server/summary.txt b/extra/http.good/server/summary.txt deleted file mode 100644 index e6d2ca62e9..0000000000 --- a/extra/http.good/server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP server diff --git a/extra/http.good/server/tags.txt b/extra/http.good/server/tags.txt deleted file mode 100644 index b0881a9ec0..0000000000 --- a/extra/http.good/server/tags.txt +++ /dev/null @@ -1,3 +0,0 @@ -enterprise -network -web diff --git a/extra/http.good/server/templating/authors.txt b/extra/http.good/server/templating/authors.txt deleted file mode 100644 index b47eafb62a..0000000000 --- a/extra/http.good/server/templating/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Slava Pestov -Matthew Willis diff --git a/extra/http.good/server/templating/templating-tests.factor b/extra/http.good/server/templating/templating-tests.factor deleted file mode 100644 index d889cd848a..0000000000 --- a/extra/http.good/server/templating/templating-tests.factor +++ /dev/null @@ -1,17 +0,0 @@ -USING: io io.files io.streams.string http.server.templating kernel tools.test - sequences ; -IN: temporary - -: test-template ( path -- ? ) - "extra/http/server/templating/test/" swap append - [ - ".fhtml" append resource-path - [ run-template-file ] with-string-writer - ] keep - ".html" append resource-path file-contents = ; - -[ t ] [ "example" test-template ] unit-test -[ t ] [ "bug" test-template ] unit-test -[ t ] [ "stack" test-template ] unit-test - -[ ] [ "<%\n%>" parse-template drop ] unit-test diff --git a/extra/http.good/server/templating/templating.factor b/extra/http.good/server/templating/templating.factor deleted file mode 100755 index f364b86524..0000000000 --- a/extra/http.good/server/templating/templating.factor +++ /dev/null @@ -1,96 +0,0 @@ -! Copyright (C) 2005 Alex Chapman -! Copyright (C) 2006, 2007 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: continuations sequences kernel parser namespaces io -io.files io.streams.lines io.streams.string html html.elements -source-files debugger combinators math quotations generic -strings splitting ; - -IN: http.server.templating - -: templating-vocab ( -- vocab-name ) "http.server.templating" ; - -! See apps/http-server/test/ or libs/furnace/ for template usage -! examples - -! We use a custom lexer so that %> ends a token even if not -! followed by whitespace -TUPLE: template-lexer ; - -: ( lines -- lexer ) - template-lexer construct-delegate ; - -M: template-lexer skip-word - [ - { - { [ 2dup nth CHAR: " = ] [ drop 1+ ] } - { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } - { [ t ] [ f skip ] } - } cond - ] change-column ; - -DEFER: <% delimiter - -: check-<% ( lexer -- col ) - "<%" over lexer-line-text rot lexer-column start* ; - -: found-<% ( accum lexer col -- accum ) - [ - over lexer-line-text - >r >r lexer-column r> r> subseq parsed - \ write-html parsed - ] 2keep 2 + swap set-lexer-column ; - -: still-looking ( accum lexer -- accum ) - [ - dup lexer-line-text swap lexer-column tail - parsed \ print-html parsed - ] keep next-line ; - -: parse-%> ( accum lexer -- accum ) - dup still-parsing? [ - dup check-<% - [ found-<% ] [ [ still-looking ] keep parse-%> ] if* - ] [ - drop - ] if ; - -: %> lexer get parse-%> ; parsing - -: parse-template-lines ( lines -- quot ) - [ - V{ } clone lexer get parse-%> f (parse-until) - ] with-parser ; - -: parse-template ( string -- quot ) - [ - use [ clone ] change - templating-vocab use+ - string-lines parse-template-lines - ] with-scope ; - -: eval-template ( string -- ) parse-template call ; - -: html-error. ( error -- ) - 
 error.
; - -: run-template-file ( filename -- ) - [ - [ - "quiet" on - parser-notes off - templating-vocab use+ - dup source-file file set ! so that reload works properly - [ - ?resource-path file-contents - [ eval-template ] [ html-error. drop ] recover - ] keep - ] with-file-vocabs - ] assert-depth drop ; - -: run-relative-template-file ( filename -- ) - file get source-file-path parent-directory - swap path+ run-template-file ; - -: template-convert ( infile outfile -- ) - [ run-template-file ] with-file-writer ; diff --git a/extra/http.good/server/templating/test/bug.fhtml b/extra/http.good/server/templating/test/bug.fhtml deleted file mode 100644 index cb66599079..0000000000 --- a/extra/http.good/server/templating/test/bug.fhtml +++ /dev/null @@ -1,5 +0,0 @@ -<% - USING: prettyprint ; - ! Hello world - 5 pprint -%> diff --git a/extra/http.good/server/templating/test/bug.html b/extra/http.good/server/templating/test/bug.html deleted file mode 100644 index 51d7b8d169..0000000000 --- a/extra/http.good/server/templating/test/bug.html +++ /dev/null @@ -1,2 +0,0 @@ -5 - diff --git a/extra/http.good/server/templating/test/example.fhtml b/extra/http.good/server/templating/test/example.fhtml deleted file mode 100644 index 211f44af9a..0000000000 --- a/extra/http.good/server/templating/test/example.fhtml +++ /dev/null @@ -1,8 +0,0 @@ -<% USING: math ; %> - - - Simple Embedded Factor Example - - <% 5 [ %>

I like repetition

<% ] times %> - - diff --git a/extra/http.good/server/templating/test/example.html b/extra/http.good/server/templating/test/example.html deleted file mode 100644 index 9bf4a08209..0000000000 --- a/extra/http.good/server/templating/test/example.html +++ /dev/null @@ -1,9 +0,0 @@ - - - - Simple Embedded Factor Example - -

I like repetition

I like repetition

I like repetition

I like repetition

I like repetition

- - - diff --git a/extra/http.good/server/templating/test/stack.fhtml b/extra/http.good/server/templating/test/stack.fhtml deleted file mode 100644 index 399711a209..0000000000 --- a/extra/http.good/server/templating/test/stack.fhtml +++ /dev/null @@ -1 +0,0 @@ -The stack: <% USING: prettyprint ; .s %> diff --git a/extra/http.good/server/templating/test/stack.html b/extra/http.good/server/templating/test/stack.html deleted file mode 100644 index ee923a6421..0000000000 --- a/extra/http.good/server/templating/test/stack.html +++ /dev/null @@ -1,2 +0,0 @@ -The stack: - diff --git a/extra/http.good/summary.txt b/extra/http.good/summary.txt deleted file mode 100644 index 8791a6f1c4..0000000000 --- a/extra/http.good/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Common code shared by HTTP client and server diff --git a/extra/http.good/tags.txt b/extra/http.good/tags.txt deleted file mode 100644 index 93e65ae758..0000000000 --- a/extra/http.good/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -web -network