diff --git a/extra/http/basic-authentication/authors.txt b/extra/http/basic-authentication/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/extra/http/basic-authentication/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/http/basic-authentication/basic-authentication-docs.factor b/extra/http/basic-authentication/basic-authentication-docs.factor deleted file mode 100644 index 68d6e6bf1d..0000000000 --- a/extra/http/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/basic-authentication/basic-authentication-tests.factor b/extra/http/basic-authentication/basic-authentication-tests.factor deleted file mode 100644 index 318123b0b4..0000000000 --- a/extra/http/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/basic-authentication/basic-authentication.factor b/extra/http/basic-authentication/basic-authentication.factor deleted file mode 100644 index dfe04dc4b5..0000000000 --- a/extra/http/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/basic-authentication/summary.txt b/extra/http/basic-authentication/summary.txt deleted file mode 100644 index 60cef7e630..0000000000 --- a/extra/http/basic-authentication/summary.txt +++ /dev/null @@ -1 +0,0 @@ -HTTP Basic Authentication implementation diff --git a/extra/http/basic-authentication/tags.txt b/extra/http/basic-authentication/tags.txt deleted file mode 100644 index c0772185a0..0000000000 --- a/extra/http/basic-authentication/tags.txt +++ /dev/null @@ -1 +0,0 @@ -web diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 5e407657a8..4fca1697a5 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -16,6 +16,8 @@ tuple-syntax namespaces ; host: "www.apple.com" path: "/index.html" port: 80 + version: "1.1" + cookies: V{ } } ] [ [ diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8b74b6dc72..1c408e44e3 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,7 +2,7 @@ ! 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 +splitting continuations calendar vectors hashtables accessors ; IN: http.client @@ -32,7 +32,7 @@ DEFER: (http-request) : do-redirect ( response -- response stream ) dup response-code 300 399 between? [ - header>> "location" peek-at + header>> "location" swap at dup "http://" head? [ absolute-redirect ] [ @@ -44,7 +44,7 @@ DEFER: (http-request) : (http-request) ( request -- response stream ) dup host>> over port>> stdio set - write-request flush read-response + dup "r" set-global write-request flush read-response do-redirect ; PRIVATE> @@ -59,8 +59,7 @@ PRIVATE> ] with-scope ; : ( -- request ) - request construct-empty - "GET" >>method ; + "GET" >>method ; : http-get-stream ( url -- response stream ) http-request ; @@ -86,7 +85,7 @@ PRIVATE> dup download-name download-to ; : ( content-type content -- request ) - request construct-empty + "POST" >>method swap >>post-data swap >>post-data-type ; diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 9fa593053c..681ebd97e2 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -29,12 +29,14 @@ blah [ TUPLE{ request + port: 80 method: "GET" path: "bar" - query: f + query: H{ } version: "1.1" - header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } } + header: H{ { "some-header" "1; 2" } { "content-length" "4" } } post-data: "blah" + cookies: V{ } } ] [ read-request-test-1 [ @@ -45,8 +47,7 @@ blah STRING: read-request-test-1' GET bar HTTP/1.1 content-length: 4 -some-header: 1 -some-header: 2 +some-header: 1; 2 blah ; @@ -60,18 +61,20 @@ read-request-test-1' 1array [ ] unit-test STRING: read-request-test-2 -HEAD http://foo/bar HTTP/1.0 +HEAD http://foo/bar HTTP/1.1 Host: www.sex.com ; [ TUPLE{ request + port: 80 method: "HEAD" path: "bar" - query: f - version: "1.0" - header: H{ { "host" V{ "www.sex.com" } } } + query: H{ } + version: "1.1" + header: H{ { "host" "www.sex.com" } } host: "www.sex.com" + cookies: V{ } } ] [ read-request-test-2 [ @@ -80,7 +83,7 @@ Host: www.sex.com ] unit-test STRING: read-response-test-1 -HTTP/1.0 404 not found +HTTP/1.1 404 not found Content-Type: text/html blah @@ -88,10 +91,11 @@ blah [ TUPLE{ response - version: "1.0" + version: "1.1" code: 404 message: "not found" - header: H{ { "content-type" V{ "text/html" } } } + header: H{ { "content-type" "text/html" } } + cookies: V{ } } ] [ read-response-test-1 @@ -100,7 +104,7 @@ blah STRING: read-response-test-1' -HTTP/1.0 404 not found +HTTP/1.1 404 not found content-type: text/html @@ -113,3 +117,8 @@ read-response-test-1' 1array [ ! normalize crlf string-lines "\n" join ] unit-test + +[ t ] [ + "rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT" + dup parse-cookies unparse-cookies = +] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 4c2834b7ca..8686d87052 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -2,34 +2,13 @@ ! 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 ; +io.encodings.utf8 namespaces unicode.case combinators +vectors sorting new-slots accessors calendar calendar.format +quotations arrays ; 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? @@ -73,6 +52,54 @@ IN: http : url-decode ( str -- str ) [ 0 swap url-decode-iter ] "" make decode-utf8 ; +: crlf "\r\n" write ; + +: add-header ( value key assoc -- ) + [ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ; + +: header-line ( line -- ) + dup first blank? [ + [ blank? ] left-trim + "last-header" get + "header" get + add-header + ] [ + ": " split1 dup [ + swap >lower dup "last-header" set + "header" get add-header + ] [ + 2drop + ] if + ] if ; + +: read-header-line ( -- ) + readln dup + empty? [ drop ] [ header-line read-header-line ] if ; + +: read-header ( -- assoc ) + H{ } clone [ + "header" [ read-header-line ] with-variable + ] keep ; + +: header-value>string ( value -- string ) + { + { [ dup number? ] [ number>string ] } + { [ dup timestamp? ] [ timestamp>http-string ] } + { [ dup string? ] [ ] } + { [ dup sequence? ] [ [ header-value>string ] map "; " join ] } + } cond ; + +: check-header-string ( str -- str ) + #! http://en.wikipedia.org/wiki/HTTP_Header_Injection + dup [ "\r\n" member? ] contains? + [ "Header injection attack" throw ] when ; + +: write-header ( assoc -- ) + >alist sort-keys [ + swap url-encode write ": " write + header-value>string check-header-string write crlf + ] assoc-each crlf ; + : query>assoc ( query -- assoc ) dup [ "&" split [ @@ -84,6 +111,50 @@ IN: http [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map "&" join ; +TUPLE: cookie name value path domain expires http-only ; + +: ( value name -- cookie ) + cookie construct-empty + swap >>name swap >>value ; + +: parse-cookies ( string -- seq ) + [ + f swap + + ";" split [ + [ blank? ] trim "=" split1 swap >lower { + { "expires" [ >>expires ] } + { "domain" [ >>domain ] } + { "path" [ >>path ] } + { "httponly" [ drop t >>http-only ] } + { "" [ drop ] } + [ dup , nip ] + } case + ] each + + drop + ] { } make ; + +: (unparse-cookie) ( key value -- ) + { + { [ dup f eq? ] [ 2drop ] } + { [ dup t eq? ] [ drop , ] } + { [ t ] [ "=" swap 3append , ] } + } cond ; + +: unparse-cookie ( cookie -- strings ) + [ + dup name>> >lower over value>> (unparse-cookie) + "path" over path>> (unparse-cookie) + "domain" over domain>> (unparse-cookie) + "expires" over expires>> (unparse-cookie) + "httponly" over http-only>> (unparse-cookie) + drop + ] { } make ; + +: unparse-cookies ( cookies -- string ) + [ unparse-cookie ] map concat "; " join ; + TUPLE: request host port @@ -93,12 +164,21 @@ query version header post-data -post-data-type ; +post-data-type +cookies ; : request construct-empty - "1.0" >>version - http-port >>port ; + "1.1" >>version + http-port >>port + H{ } clone >>query + V{ } clone >>cookies ; + +: query-param ( request key -- value ) + swap query>> at ; + +: set-query-param ( request value key -- request ) + pick query>> set-at ; : url>path ( url -- path ) url-decode "http://" ?head @@ -132,12 +212,15 @@ post-data-type ; : read-request-header ( request -- request ) read-header >>header ; +: header ( request/response key -- value ) + swap header>> at ; + SYMBOL: max-post-request 1024 256 * max-post-request set-global : content-length ( header -- n ) - "content-length" peek-at string>number dup [ + "content-length" swap at string>number dup [ dup max-post-request get > [ "content-length > max-post-request" throw ] when @@ -151,10 +234,13 @@ SYMBOL: max-post-request [ string>number ] [ http-port ] if* ; : extract-host ( request -- request ) - dup header>> "host" peek-at parse-host >r >>host r> >>port ; + dup "host" header parse-host >r >>host r> >>port ; : extract-post-data-type ( request -- request ) - dup header>> "content-type" peek-at >>post-data-type ; + dup "content-type" header >>post-data-type ; + +: extract-cookies ( request -- request ) + dup "cookie" header [ parse-cookies >>cookies ] when* ; : read-request ( -- request ) @@ -164,7 +250,8 @@ SYMBOL: max-post-request read-request-header read-post-data extract-host - extract-post-data-type ; + extract-post-data-type + extract-cookies ; : write-method ( request -- request ) dup method>> write bl ; @@ -184,9 +271,10 @@ SYMBOL: max-post-request : 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* + over host>> [ "host" pick set-at ] when* + over post-data>> [ length "content-length" pick set-at ] when* + over post-data-type>> [ "content-type" pick set-at ] when* + over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when* write-header ; : write-post-data ( request -- request ) @@ -194,7 +282,7 @@ SYMBOL: max-post-request : write-request ( request -- ) write-method - write-url + write-request-url write-version write-request-header write-post-data @@ -209,30 +297,42 @@ SYMBOL: max-post-request ":" write dup port>> number>string write ] when - "/" write + dup path>> "/" head? [ "/" write ] unless write-url drop ] with-string-writer ; +: set-header ( request/response value key -- request/response ) + pick header>> set-at ; + +GENERIC: write-response ( response -- ) + +GENERIC: write-full-response ( request response -- ) + TUPLE: response version code message -header ; +header +cookies +body ; : response construct-empty - "1.0" >>version - H{ } clone >>header ; + "1.1" >>version + H{ } clone >>header + "close" "connection" set-header + now timestamp>http-string "date" set-header + V{ } clone >>cookies ; : read-response-version - " " read-until + " \t" read-until [ "Bad response: version" throw ] unless parse-version >>version ; : read-response-code - " " read-until [ "Bad response: code" throw ] unless + " \t" read-until [ "Bad response: code" throw ] unless string>number [ "Bad response: code" throw ] unless* >>code ; @@ -240,7 +340,8 @@ header ; readln >>message ; : read-response-header - read-header >>header ; + read-header >>header + dup "set-cookie" header [ parse-cookies >>cookies ] when* ; : read-response ( -- response ) @@ -260,9 +361,20 @@ header ; dup message>> write crlf ; : write-response-header ( response -- response ) - dup header>> write-header ; + dup header>> clone + over cookies>> f like + [ unparse-cookies "set-cookie" pick set-at ] when* + write-header ; -: write-response ( respose -- ) +: write-response-body ( response -- response ) + dup body>> { + { [ dup not ] [ drop ] } + { [ dup string? ] [ write ] } + { [ dup callable? ] [ call ] } + { [ t ] [ stdio get stream-copy ] } + } cond ; + +M: response write-response ( respose -- ) write-response-version write-response-code write-response-message @@ -270,8 +382,39 @@ header ; flush drop ; -: set-response-header ( response value key -- response ) - pick header>> -rot replace-at drop ; +M: response write-full-response ( request response -- ) + dup write-response + swap method>> "HEAD" = [ write-response-body ] unless ; -: set-content-type ( response content-type -- response ) - "content-type" set-response-header ; +: set-content-type ( request/response content-type -- request/response ) + "content-type" set-header ; + +: get-cookie ( request/response name -- cookie/f ) + >r cookies>> r> [ swap name>> = ] curry find nip ; + +: delete-cookie ( request/response name -- ) + over cookies>> >r get-cookie r> delete ; + +: put-cookie ( request/response cookie -- request/response ) + [ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep + over cookies>> push ; + +TUPLE: raw-response +version +code +message +body ; + +: ( -- response ) + raw-response construct-empty + "1.1" >>version ; + +M: raw-response write-response ( respose -- ) + write-response-version + write-response-code + write-response-message + write-response-body + drop ; + +M: raw-response write-full-response ( response -- ) + write-response nip ; diff --git a/extra/http/mime/mime.factor b/extra/http/mime/mime.factor old mode 100644 new mode 100755 index 3365127d87..f9097ecce3 --- a/extra/http/mime/mime.factor +++ b/extra/http/mime/mime.factor @@ -30,5 +30,6 @@ H{ { "pdf" "application/pdf" } { "factor" "text/plain" } + { "cgi" "application/x-cgi-script" } { "fhtml" "application/x-factor-server-page" } } "mime-types" set-global diff --git a/extra/http/server/authentication/basic/basic.factor b/extra/http/server/authentication/basic/basic.factor new file mode 100755 index 0000000000..b6dbed4b62 --- /dev/null +++ b/extra/http/server/authentication/basic/basic.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +IN: http.server.authentication.basic +USING: accessors new-slots quotations assocs kernel splitting +base64 crypto.sha2 html.elements io combinators http.server +http sequences ; + +! 'users' is a quotation or an assoc. The quotation +! has stack effect ( sha-256-string username -- ? ). +! 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 'users' is an assoc then +! it is a mapping of usernames to sha-256 hashed passwords. +TUPLE: realm responder name users ; + +C: realm + +: user-authorized? ( password username realm -- ? ) + users>> { + { [ dup callable? ] [ call ] } + { [ dup assoc? ] [ at = ] } + } cond ; + +: authorization-ok? ( realm header -- bool ) + #! Given the realm and the 'Authorization' header, + #! authenticate the user. + dup [ + " " split1 swap "Basic" = [ + base64> ":" split1 string>sha-256-string + spin user-authorized? + ] [ + 2drop f + ] if + ] [ + 2drop f + ] if ; + +: <401> ( realm -- response ) + 401 "Unauthorized" + "Basic realm=\"" rot name>> "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>body ; + +M: realm call-responder ( request path realm -- response ) + pick "authorization" header dupd authorization-ok? + [ responder>> call-responder ] [ 2nip <401> ] if ; diff --git a/extra/http/server/callbacks/callbacks.factor b/extra/http/server/callbacks/callbacks.factor new file mode 100755 index 0000000000..a000a76040 --- /dev/null +++ b/extra/http/server/callbacks/callbacks.factor @@ -0,0 +1,170 @@ +! Copyright (C) 2004 Chris Double. +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: html http http.server io kernel math namespaces +continuations calendar sequences assocs new-slots hashtables +accessors arrays alarms quotations combinators ; +IN: http.server.callbacks + +SYMBOL: responder + +TUPLE: callback-responder responder callbacks ; + +: ( responder -- responder' ) + #! A continuation responder is a special type of session + #! manager. However it works entirely differently from + #! the URL and cookie session managers. + H{ } clone callback-responder construct-boa ; + +TUPLE: callback cont quot expires alarm responder ; + +: timeout 20 minutes ; + +: timeout-callback ( callback -- ) + dup alarm>> cancel-alarm + dup responder>> callbacks>> delete-at ; + +: touch-callback ( callback -- ) + dup expires>> [ + dup alarm>> [ cancel-alarm ] when* + dup [ timeout-callback ] curry timeout later >>alarm + ] when drop ; + +: ( cont quot expires? -- callback ) + [ f responder get callback construct-boa ] keep + [ dup touch-callback ] when ; + +: invoke-callback ( request exit-cont callback -- response ) + [ quot>> 3array ] keep cont>> continue-with ; + +: register-callback ( cont quot expires? -- id ) + + responder get callbacks>> generate-key + [ responder get callbacks>> set-at ] keep ; + +SYMBOL: exit-continuation + +: exit-with exit-continuation get continue-with ; + +: forward-to-url ( url -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + exit-with ; + +: cont-id "factorcontid" ; + +: id>url ( id -- url ) + request get clone + swap cont-id associate >>query + request-url ; + +: forward-to-id ( id -- * ) + #! When executed inside a 'show' call, this will force a + #! HTTP 302 to occur to instruct the browser to forward to + #! the request URL. + id>url forward-to-url ; + +: restore-request ( pair -- ) + first3 >r exit-continuation set request set r> call ; + +: resume-page ( request page responder callback -- * ) + dup touch-callback + >r 2drop exit-continuation get + r> invoke-callback ; + +SYMBOL: post-refresh-get? + +: redirect-to-here ( -- ) + #! Force a redirect to the client browser so that the browser + #! goes to the current point in the code. This forces an URL + #! change on the browser so that refreshing that URL will + #! immediately run from this code point. This prevents the + #! "this request will issue a POST" warning from the browser + #! and prevents re-running the previous POST logic. This is + #! known as the 'post-refresh-get' pattern. + post-refresh-get? get [ + [ + [ ] t register-callback forward-to-id + ] callcc1 restore-request + ] [ + post-refresh-get? on + ] if ; + +SYMBOL: current-show + +: store-current-show ( -- ) + #! Store the current continuation in the variable 'current-show' + #! so it can be returned to later by 'quot-id'. Note that it + #! recalls itself when the continuation is called to ensure that + #! it resets its value back to the most recent show call. + [ current-show set f ] callcc1 + [ restore-request store-current-show ] when* ; + +: show-final ( quot -- * ) + [ + >r store-current-show redirect-to-here r> call exit-with + ] with-scope ; inline + +M: callback-responder call-responder + [ + [ + exit-continuation set + dup responder set + pick request set + pick cont-id query-param over callbacks>> at [ + resume-page + ] [ + responder>> call-responder + "Continuation responder pages must use show-final" throw + ] if* + ] with-scope + ] callcc1 >r 3drop r> ; + +: show-page ( quot -- ) + [ + >r store-current-show redirect-to-here r> + [ + [ ] register-callback + call + exit-with + ] callcc1 restore-request + ] with-scope ; inline + +: quot-id ( quot -- id ) + current-show get swap t register-callback ; + +: quot-url ( quot -- url ) + quot-id id>url ; + +! SYMBOL: current-show +! +! : store-current-show ( -- ) +! #! Store the current continuation in the variable 'current-show' +! #! so it can be returned to later by href callbacks. Note that it +! #! recalls itself when the continuation is called to ensure that +! #! it resets its value back to the most recent show call. +! [ ( 0 -- ) +! [ ( 0 1 -- ) +! current-show set ( 0 -- ) +! continue +! ] callcc1 +! nip +! store-current-show +! ] callcc0 ; +! + +! +! : show-final ( quot -- * ) +! store-current-show +! redirect-to-here +! call +! exit-with ; inline +! +! : show-page ( quot -- request ) +! store-current-show redirect-to-here +! [ +! register-continuation +! call +! exit-with +! ] callcc1 restore-request ; inline diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor new file mode 100755 index 0000000000..9950a9a4a4 --- /dev/null +++ b/extra/http/server/cgi/cgi.factor @@ -0,0 +1,65 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel assocs io.files combinators +arrays io.launcher io http.server.static http.server +http accessors sequences strings math.parser ; +IN: http.server.cgi + +: post? request get method>> "POST" = ; + +: cgi-variables ( script-path -- assoc ) + #! This needs some work. + [ + "CGI/1.0" "GATEWAY_INTERFACE" set + "HTTP/" request get version>> append "SERVER_PROTOCOL" set + "Factor" "SERVER_SOFTWARE" set + + dup "PATH_TRANSLATED" set + "SCRIPT_FILENAME" set + + request get path>> "SCRIPT_NAME" set + + request get host>> "SERVER_NAME" set + request get port>> number>string "SERVER_PORT" set + "" "PATH_INFO" set + "" "REMOTE_HOST" set + "" "REMOTE_ADDR" set + "" "AUTH_TYPE" set + "" "REMOTE_USER" set + "" "REMOTE_IDENT" set + + request get method>> "REQUEST_METHOD" set + request get query>> assoc>query "QUERY_STRING" set + request get "cookie" header "HTTP_COOKIE" set + + request get "user-agent" header "HTTP_USER_AGENT" set + request get "accept" header "HTTP_ACCEPT" set + + post? [ + request get post-data-type>> "CONTENT_TYPE" set + request get post-data>> length number>string "CONTENT_LENGTH" set + ] when + ] H{ } make-assoc ; + +: cgi-descriptor ( name -- desc ) + [ + dup 1array +arguments+ set + cgi-variables +environment+ set + ] H{ } make-assoc ; + +: serve-cgi ( name -- response ) + + 200 >>code + "CGI output follows" >>message + swap [ + stdio get swap cgi-descriptor [ + post? [ + request get post-data>> write flush + ] when + stdio get swap (stream-copy) + ] with-stream + ] curry >>body ; + +: enable-cgi ( responder -- responder ) + [ serve-cgi ] "application/x-cgi-script" + pick special>> set-at ; diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index a67d21a640..8616071580 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -1,45 +1,53 @@ USING: http.server tools.test kernel namespaces accessors -new-slots assocs.lib io http math sequences ; +new-slots io http math sequences assocs ; IN: temporary -TUPLE: mock-responder ; +TUPLE: mock-responder path ; -: ( path -- responder ) - mock-responder construct-delegate ; +C: mock-responder -M: mock-responder do-responder +M: mock-responder call-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 ; + write-response get ; [ - "" - "foo" add-responder - "bar" add-responder - "baz/" - "123" add-responder + + "foo" "foo" add-responder + "bar" "bar" add-responder + + "123" "123" add-responder "default" >>default - add-responder + "baz" add-responder default-host set + [ "foo" ] [ + "foo" default-host get find-responder path>> nip + ] unit-test + + [ "bar" ] [ + "bar" default-host get find-responder path>> nip + ] 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 ] [ "default" "baz/xxx//" check-dispatch ] unit-test + [ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test [ t ] [ "123" "baz/123" 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 + header>> "location" swap at "baz/" tail? r> and ] unit-test ] with-scope diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index e06ae6a95c..3780b2110d 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,24 +2,17 @@ ! 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 ; +new-slots html.elements accessors math.parser combinators.lib +vocabs.loader debugger html continuations random ; IN: http.server -TUPLE: responder path directory ; +GENERIC: call-responder ( request path responder -- response ) -: ( path -- responder ) - "/" ?tail responder construct-boa ; +TUPLE: trivial-responder response ; -GENERIC: do-responder ( request path responder -- quot response ) +C: trivial-responder -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>> ; +M: trivial-responder call-responder 2nip response>> call ; : trivial-response-body ( code message -- ) @@ -28,23 +21,30 @@ M: trivial-responder do-responder ; -: ( code message -- quot response ) - [ [ trivial-response-body ] 2curry ] 2keep +: ( code message -- response ) + + 2over [ trivial-response-body ] 2curry >>body "text/html" set-content-type swap >>message swap >>code ; -: <404> ( -- quot response ) +: <404> ( -- response ) 404 "Not Found" ; -: ( to code message -- quot response ) - - rot "location" set-response-header ; +SYMBOL: 404-responder -: ( to -- quot response ) +[ <404> ] 404-responder set-global + +: ( to code message -- response ) + + swap "location" set-header ; + +\ DEBUG add-input-logging + +: ( to -- response ) 301 "Moved Permanently" ; -: ( to -- quot response ) +: ( to -- response ) 307 "Temporary Redirect" ; : ( content-type -- response ) @@ -52,66 +52,58 @@ M: trivial-responder do-responder 200 >>code swap set-content-type ; -TUPLE: dispatcher responders default ; +TUPLE: dispatcher default responders ; -: responder-matches? ( path responder -- ? ) - path>> head? ; +: get-responder ( name dispatcher -- responder ) + tuck responders>> at [ ] [ default>> ] ?if ; -TUPLE: no-/-responder ; +: find-responder ( path dispatcher -- path responder ) + >r [ CHAR: / = ] left-trim "/" split1 + swap [ CHAR: / = ] right-trim r> get-responder ; -M: no-/-responder do-responder - 2drop +: redirect-with-/ ( request -- response ) dup path>> "/" append >>path request-url ; -: ( -- responder ) - "" no-/-responder construct-delegate ; +M: dispatcher call-responder + over [ + find-responder call-responder + ] [ + 2drop redirect-with-/ + ] if ; - no-/-responder set-global +: ( -- dispatcher ) + 404-responder get-global H{ } clone + dispatcher construct-boa ; -: 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 ; +: add-responder ( dispatcher responder path -- dispatcher ) + pick responders>> set-at ; SYMBOL: virtual-hosts SYMBOL: default-host virtual-hosts global [ drop H{ } clone ] cache drop -default-host global [ drop 404-responder ] cache drop +default-host global [ drop 404-responder get-global ] cache drop : find-virtual-host ( host -- responder ) virtual-hosts get at [ default-host get ] unless* ; +: <500> ( error -- response ) + 500 "Internal server error" + swap [ + "Internal server error" [ + [ print-error nl :c ] with-html-stream + ] simple-page + ] curry >>body ; + : handle-request ( request -- ) [ - dup path>> over host>> find-virtual-host - call-responder - write-response - ] keep method>> "HEAD" = [ drop ] [ call ] if ; + dup dup path>> over host>> + find-virtual-host call-responder + ] [ <500> ] recover + dup write-response + swap method>> "HEAD" = + [ drop ] [ write-response-body ] if ; : default-timeout 1 minutes stdio get set-timeout ; @@ -120,12 +112,21 @@ LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; +SYMBOL: development-mode + +: (httpd) ( -- ) + default-timeout + development-mode get-global + [ global [ refresh-all ] bind ] when + read-request dup log-request handle-request ; + : httpd ( port -- ) - internet-server "http.server" [ - default-timeout - read-request dup log-request handle-request - ] with-server ; + internet-server "http.server" [ (httpd) ] with-server ; : httpd-main ( -- ) 8888 httpd ; MAIN: httpd-main + +: generate-key ( assoc -- str ) + 4 big-random >hex dup pick key? + [ drop generate-key ] [ nip ] if ; diff --git a/extra/http/server/sessions/authors.txt b/extra/http/server/sessions/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/http/server/sessions/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor new file mode 100755 index 0000000000..988ae41609 --- /dev/null +++ b/extra/http/server/sessions/sessions-tests.factor @@ -0,0 +1,32 @@ +IN: temporary +USING: tools.test http.server.sessions math namespaces +kernel accessors ; + +"1234" f [ + [ ] [ 3 "x" sset ] unit-test + + [ 9 ] [ "x" sget sq ] unit-test + + [ ] [ "x" [ 1- ] schange ] unit-test + + [ 4 ] [ "x" sget sq ] unit-test +] with-session + +[ t ] [ f url-sessions? ] unit-test +[ t ] [ f cookie-sessions? ] unit-test + +[ ] [ + f + [ 0 "x" sset ] >>init + "manager" set +] unit-test + +[ { 5 0 } ] [ + [ + "manager" get new-session + dup "manager" get get-session [ 5 "a" sset ] with-session + dup "manager" get get-session [ "a" sget , ] with-session + dup "manager" get get-session [ "x" sget , ] with-session + "manager" get get-session delete-session + ] { } make +] unit-test diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor new file mode 100755 index 0000000000..7d6ca5a637 --- /dev/null +++ b/extra/http/server/sessions/sessions.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs calendar kernel math.parser namespaces random +boxes alarms new-slots accessors http http.server +quotations hashtables sequences ; +IN: http.server.sessions + +! ! ! ! ! ! +! WARNING: this session manager is vulnerable to XSRF attacks +! ! ! ! ! ! + +TUPLE: session-manager responder init sessions ; + +: ( responder class -- responder' ) + >r [ ] H{ } clone session-manager construct-boa r> + construct-delegate ; inline + +TUPLE: session id manager namespace alarm ; + +: ( id manager -- session ) + H{ } clone \ session construct-boa ; + +: timeout ( -- dt ) 20 minutes ; + +: cancel-timeout ( session -- ) + alarm>> ?box [ cancel-alarm ] [ drop ] if ; + +: delete-session ( session -- ) + dup cancel-timeout + dup manager>> sessions>> delete-at ; + +: touch-session ( session -- ) + dup cancel-timeout + dup [ delete-session ] curry timeout later + swap session-alarm >box ; + +: session ( -- assoc ) \ session get namespace>> ; + +: sget ( key -- value ) session at ; + +: sset ( value key -- ) session set-at ; + +: schange ( key quot -- ) session swap change-at ; inline + +: with-session ( session quot -- ) + >r \ session r> with-variable ; inline + +: new-session ( responder -- id ) + [ sessions>> generate-key dup ] keep + [ dup touch-session ] keep + [ init>> with-session ] 2keep + >r over r> sessions>> set-at ; + +: get-session ( id responder -- session ) + sessions>> tuck at* [ + nip dup touch-session + ] [ + 2drop f + ] if ; + +: call-responder/session ( request path responder session -- response ) + [ responder>> call-responder ] with-session ; + +: sessions ( -- manager/f ) + \ session get dup [ manager>> ] when ; + +GENERIC: session-link* ( url query sessions -- string ) + +M: object session-link* 2drop url-encode ; + +: session-link ( url query -- string ) sessions session-link* ; + +TUPLE: url-sessions ; + +: ( responder -- responder' ) + url-sessions ; + +: sess-id "factorsessid" ; + +M: url-sessions call-responder ( request path responder -- response ) + pick sess-id query-param over get-session [ + call-responder/session + ] [ + new-session nip sess-id set-query-param + request-url + ] if* ; + +M: url-sessions session-link* + drop + \ session get id>> sess-id associate union assoc>query + >r url-encode r> + dup assoc-empty? [ drop ] [ "?" swap 3append ] if ; + +TUPLE: cookie-sessions ; + +: ( responder -- responder' ) + cookie-sessions ; + +: get-session-cookie ( request -- cookie ) + sess-id get-cookie ; + +: ( id -- cookie ) + sess-id ; + +M: cookie-sessions call-responder ( request path responder -- response ) + pick get-session-cookie value>> over get-session [ + call-responder/session + ] [ + dup new-session + [ over get-session call-responder/session ] keep + put-cookie + ] if* ; diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor new file mode 100755 index 0000000000..e1a7a3cae9 --- /dev/null +++ b/extra/http/server/static/static.factor @@ -0,0 +1,95 @@ +! Copyright (C) 2004, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: calendar html io io.files kernel math math.parser http +http.server namespaces parser sequences strings assocs +hashtables debugger http.mime sorting html.elements logging +calendar.format new-slots accessors ; +IN: http.server.static + +SYMBOL: responder + +! special maps mime types to quots with effect ( path -- ) +TUPLE: file-responder root hook special ; + +: unix-time>timestamp ( n -- timestamp ) + >r unix-1970 r> seconds time+ ; + +: file-http-date ( filename -- string ) + file-modified unix-time>timestamp timestamp>http-string ; + +: last-modified-matches? ( filename -- ? ) + file-http-date dup [ + request get "if-modified-since" header = + ] when ; + +: <304> ( -- response ) + 304 "Not modified" ; + +: ( root hook -- responder ) + H{ } clone file-responder construct-boa ; + +: ( root -- responder ) + [ + + over file-length "content-length" set-header + over file-http-date "last-modified" set-header + swap [ stdio get stream-copy ] curry >>body + ] ; + +: serve-static ( filename mime-type -- response ) + over last-modified-matches? + [ 2drop <304> ] [ responder get hook>> call ] if ; + +: serving-path ( filename -- filename ) + "" or responder get root>> swap path+ ; + +: serve-file ( filename -- response ) + dup mime-type + dup responder get special>> at + [ call ] [ serve-static ] ?if ; + +\ serve-file NOTICE add-input-logging + +: file. ( name dirp -- ) + [ "/" append ] when + dup write ; + +: directory. ( path -- ) + dup file-name [ +

dup file-name write

+
    + directory sort-keys + [
  • file.
    • ] assoc-each +
+ ] simple-html-document ; + +: list-directory ( directory -- response ) + "text/html" + swap [ directory. ] curry >>body ; + +: find-index ( filename -- path ) + { "index.html" "index.fhtml" } + [ dupd path+ exists? ] find nip + dup [ path+ ] [ nip ] if ; + +: serve-directory ( filename -- response ) + dup "/" tail? [ + dup find-index + [ serve-file ] [ list-directory ] ?if + ] [ + drop request get redirect-with-/ + ] if ; + +: serve-object ( filename -- response ) + serving-path dup exists? [ + dup directory? [ serve-directory ] [ serve-file ] if + ] [ + drop <404> + ] if ; + +M: file-responder call-responder ( request path responder -- response ) + [ + responder set + swap request set + serve-object + ] with-scope ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 3b0dcb8e5e..b298faca74 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -4,7 +4,8 @@ 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 ; +strings splitting accessors http.server.static http.server +assocs ; IN: http.server.templating @@ -82,10 +83,10 @@ DEFER: <% delimiter templating-vocab use+ ! so that reload works properly dup source-file file set - dup ?resource-path file-contents + ?resource-path file-contents [ eval-template ] [ html-error. drop ] recover ] with-file-vocabs - ] assert-depth drop ; + ] curry assert-depth ; : run-relative-template-file ( filename -- ) file get source-file-path parent-directory @@ -93,3 +94,13 @@ DEFER: <% delimiter : template-convert ( infile outfile -- ) [ run-template-file ] with-file-writer ; + +! file responder integration +: serve-fhtml ( filename -- response ) + "text/html" + swap [ run-template-file ] curry >>body ; + +: enable-fhtml ( responder -- responder ) + [ serve-fhtml ] + "application/x-factor-server-page" + pick special>> set-at ; diff --git a/extra/webapps/cgi/authors.txt b/extra/webapps/cgi/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/cgi/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor deleted file mode 100755 index 5dba9dae00..0000000000 --- a/extra/webapps/cgi/cgi.factor +++ /dev/null @@ -1,75 +0,0 @@ -! Copyright (C) 2007, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel assocs io.files combinators -arrays io.launcher io http.server.responders webapps.file -sequences strings math.parser unicode.case ; -IN: webapps.cgi - -SYMBOL: cgi-root - -: post? "method" get "post" = ; - -: cgi-variables ( script-path -- assoc ) - #! This needs some work. - [ - "CGI/1.0" "GATEWAY_INTERFACE" set - "HTTP/1.0" "SERVER_PROTOCOL" set - "Factor" "SERVER_SOFTWARE" set - - dup "PATH_TRANSLATED" set - "SCRIPT_FILENAME" set - - "request" get "SCRIPT_NAME" set - - host "SERVER_NAME" set - "" "SERVER_PORT" set - "" "PATH_INFO" set - "" "REMOTE_HOST" set - "" "REMOTE_ADDR" set - "" "AUTH_TYPE" set - "" "REMOTE_USER" set - "" "REMOTE_IDENT" set - - "method" get >upper "REQUEST_METHOD" set - "raw-query" get "QUERY_STRING" set - "cookie" header-param "HTTP_COOKIE" set - - "user-agent" header-param "HTTP_USER_AGENT" set - "accept" header-param "HTTP_ACCEPT" set - - post? [ - "content-type" header-param "CONTENT_TYPE" set - "raw-response" get length number>string "CONTENT_LENGTH" set - ] when - ] H{ } make-assoc ; - -: cgi-descriptor ( name -- desc ) - [ - cgi-root get swap path+ dup 1array +arguments+ set - cgi-variables +environment+ set - ] H{ } make-assoc ; - -: (do-cgi) ( name -- ) - "200 CGI output follows" response - stdio get swap cgi-descriptor [ - post? [ - "raw-response" get write flush - ] when - stdio get swap (stream-copy) - ] with-stream ; - -: serve-regular-file ( -- ) - cgi-root get doc-root [ file-responder ] with-variable ; - -: do-cgi ( name -- ) - { - { [ dup ".cgi" tail? not ] [ drop serve-regular-file ] } - { [ dup empty? ] [ "403 forbidden" httpd-error ] } - { [ cgi-root get not ] [ "404 cgi-root not set" httpd-error ] } - { [ ".." over subseq? ] [ "403 forbidden" httpd-error ] } - { [ t ] [ (do-cgi) ] } - } cond ; - -global [ - "cgi" [ "argument" get do-cgi ] add-simple-responder -] bind diff --git a/extra/webapps/file/authors.txt b/extra/webapps/file/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/file/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor deleted file mode 100755 index 411c70c76a..0000000000 --- a/extra/webapps/file/file.factor +++ /dev/null @@ -1,136 +0,0 @@ -! Copyright (C) 2004, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: calendar html io io.files kernel math math.parser -http.server.responders http.server.templating namespaces parser -sequences strings assocs hashtables debugger http.mime sorting -html.elements logging calendar.format ; -IN: webapps.file - -SYMBOL: doc-root - -: serving-path ( filename -- filename ) - "" or doc-root get swap path+ ; - -: unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds time+ ; - -: file-http-date ( filename -- string ) - file-modified unix-time>timestamp timestamp>http-string ; - -: file-response ( filename mime-type -- ) - "200 OK" response - [ - "Content-Type" set - dup file-length number>string "Content-Length" set - file-http-date "Last-Modified" set - now timestamp>http-string "Date" set - ] H{ } make-assoc print-header ; - -: last-modified-matches? ( filename -- bool ) - file-http-date dup [ - "if-modified-since" header-param = - ] when ; - -: not-modified-response ( -- ) - "304 Not Modified" response - now timestamp>http-string "Date" associate print-header ; - -! You can override how files are served in a custom responder -SYMBOL: serve-file-hook - -[ - dupd - file-response - stdio get stream-copy -] serve-file-hook set-global - -: serve-static ( filename mime-type -- ) - over last-modified-matches? [ - 2drop not-modified-response - ] [ - "method" get "head" = [ - file-response - ] [ - serve-file-hook get call - ] if - ] if ; - -SYMBOL: page - -: run-page ( filename -- ) - dup - [ [ dup page set run-template-file ] with-scope ] try - drop ; - -\ run-page DEBUG add-input-logging - -: include-page ( filename -- ) - serving-path run-page ; - -: serve-fhtml ( filename -- ) - serving-html - "method" get "head" = [ drop ] [ run-page ] if ; - -: serve-file ( filename -- ) - dup mime-type dup "application/x-factor-server-page" = - [ drop serve-fhtml ] [ serve-static ] if ; - -\ serve-file NOTICE add-input-logging - -: file. ( name dirp -- ) - [ "/" append ] when - dup write ; - -: directory. ( path request -- ) - dup [ -

write

-
    - directory sort-keys - [
  • file.
    • ] assoc-each -
- ] simple-html-document ; - -: list-directory ( directory -- ) - serving-html - "method" get "head" = [ - drop - ] [ - "request" get directory. - ] if ; - -: find-index ( filename -- path ) - { "index.html" "index.fhtml" } - [ dupd path+ exists? ] find nip - dup [ path+ ] [ nip ] if ; - -: serve-directory ( filename -- ) - dup "/" tail? [ - dup find-index - [ serve-file ] [ list-directory ] ?if - ] [ - drop directory-no/ - ] if ; - -: serve-object ( filename -- ) - serving-path dup exists? [ - dup directory? [ serve-directory ] [ serve-file ] if - ] [ - drop "404 not found" httpd-error - ] if ; - -: file-responder ( -- ) - doc-root get [ - "argument" get serve-object - ] [ - "404 doc-root not set" httpd-error - ] if ; - -global [ - ! Serves files from a directory stored in the doc-root - ! variable. You can set the variable in the global - ! namespace, or inside the responder. - "file" [ file-responder ] add-simple-responder - - ! The root directory is served by... - "file" set-default-responder -] bind \ No newline at end of file diff --git a/extra/webapps/source/authors.txt b/extra/webapps/source/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/webapps/source/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/webapps/source/source.factor b/extra/webapps/source/source.factor deleted file mode 100755 index 98fb5b8873..0000000000 --- a/extra/webapps/source/source.factor +++ /dev/null @@ -1,35 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io.files namespaces webapps.file http.server.responders -xmode.code2html kernel html sequences ; -IN: webapps.source - -! This responder is a potential security problem. Make sure you -! don't have sensitive files stored under vm/, core/, extra/ -! or misc/. - -: check-source-path ( path -- ? ) - { "vm/" "core/" "extra/" "misc/" } - [ head? ] with contains? ; - -: source-responder ( path mime-type -- ) - drop - serving-html - [ - dup file-name swap htmlize-stream - ] with-html-stream ; - -global [ - ! Serve up our own source code - "source" [ - "argument" get check-source-path [ - [ - "" resource-path doc-root set - [ source-responder ] serve-file-hook set - file-responder - ] with-scope - ] [ - "403 forbidden" httpd-error - ] if - ] add-simple-responder -] bind diff --git a/extra/xmode/code2html/responder/responder.factor b/extra/xmode/code2html/responder/responder.factor new file mode 100755 index 0000000000..d14ffd93b3 --- /dev/null +++ b/extra/xmode/code2html/responder/responder.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2007, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.files namespaces http.server http.server.static http +xmode.code2html kernel html sequences accessors ; +IN: xmode.code2html.responder + +: ( root -- responder ) + [ + drop + "text/html" + over file-http-date "last-modified" set-header + swap [ + dup file-name swap htmlize-stream + ] curry >>body + ] ;