diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index 8197e57969..a989e091bb 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -19,3 +19,6 @@ TUPLE: box value full? ; : ?box ( box -- value/f ? ) dup box-full? [ box> t ] [ drop f f ] if ; + +: if-box? ( box quot -- ) + >r ?box r> [ drop ] if ; inline diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 8bdd9b902f..57743ce9e1 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -4,7 +4,7 @@ USING: namespaces sequences io.files kernel assocs words vocabs definitions parser continuations inspector debugger io io.styles io.streams.lines hashtables sorting prettyprint source-files arrays combinators strings system math.parser compiler.errors -splitting ; +splitting init ; IN: vocabs.loader SYMBOL: vocab-roots @@ -175,7 +175,13 @@ SYMBOL: failures : refresh ( prefix -- ) to-refresh do-refresh ; -: refresh-all ( -- ) "" refresh ; +SYMBOL: sources-changed? + +[ t sources-changed? set-global ] "vocabs.loader" add-init-hook + +: refresh-all ( -- ) + sources-changed? get-global + [ "" refresh f sources-changed? set-global ] when ; GENERIC: (load-vocab) ( name -- vocab ) diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index a50e1817e1..d008b7b462 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -87,5 +87,4 @@ PRIVATE> from-now f add-alarm ; : cancel-alarm ( alarm -- ) - alarm-entry ?box - [ alarms get-global heap-delete ] [ drop ] if ; + alarm-entry [ alarms get-global heap-delete ] if-box? ; diff --git a/extra/concurrency/flags/flags-tests.factor b/extra/concurrency/flags/flags-tests.factor new file mode 100755 index 0000000000..44934b59c4 --- /dev/null +++ b/extra/concurrency/flags/flags-tests.factor @@ -0,0 +1,46 @@ +IN: temporary +USING: tools.test concurrency.flags kernel threads locals ; + +:: flag-test-1 ( -- ) + [let | f [ ] | + [ f raise-flag ] "Flag test" spawn drop + f lower-flag + f flag-value? + ] ; + +[ f ] [ flag-test-1 ] unit-test + +:: flag-test-2 ( -- ) + [let | f [ ] | + [ 1000 sleep f raise-flag ] "Flag test" spawn drop + f lower-flag + f flag-value? + ] ; + +[ f ] [ flag-test-2 ] unit-test + +:: flag-test-3 ( -- ) + [let | f [ ] | + f raise-flag + f flag-value? + ] ; + +[ t ] [ flag-test-3 ] unit-test + +:: flag-test-4 ( -- ) + [let | f [ ] | + [ f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f flag-value? + ] ; + +[ t ] [ flag-test-4 ] unit-test + +:: flag-test-5 ( -- ) + [let | f [ ] | + [ 1000 sleep f raise-flag ] "Flag test" spawn drop + f wait-for-flag + f flag-value? + ] ; + +[ t ] [ flag-test-5 ] unit-test diff --git a/extra/concurrency/flags/flags.factor b/extra/concurrency/flags/flags.factor old mode 100644 new mode 100755 index 888b617b85..d598bf0b59 --- a/extra/concurrency/flags/flags.factor +++ b/extra/concurrency/flags/flags.factor @@ -9,8 +9,8 @@ TUPLE: flag value? thread ; : raise-flag ( flag -- ) dup flag-value? [ - dup flag-thread ?box - [ resume ] [ drop t over set-flag-value? ] if + t over set-flag-value? + dup flag-thread [ resume ] if-box? ] unless drop ; : wait-for-flag ( flag -- ) @@ -19,8 +19,4 @@ TUPLE: flag value? thread ; ] if ; : lower-flag ( flag -- ) - dup flag-value? [ - f swap set-flag-value? - ] [ - wait-for-flag - ] if ; + dup wait-for-flag f swap set-flag-value? ; diff --git a/extra/help/help.factor b/extra/help/help.factor index 490374a384..9332e6aff8 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -132,13 +132,13 @@ M: word set-article-parent swap "help-parent" set-word-prop ; nl "Debugger commands:" print nl - ":help - documentation for this error" print - ":s - data stack at exception time" print - ":r - retain stack at exception time" print - ":c - call stack at exception time" print + ":s - data stack at error time" print + ":r - retain stack at error time" print + ":c - call stack at error time" print ":edit - jump to source location (parse errors only)" print - ":get ( var -- value ) accesses variables at time of the error" print ; + ":get ( var -- value ) accesses variables at time of the error" print + ":vars - list all variables at error time"; : :help ( -- ) error get delegates [ error-help ] map [ ] subset diff --git a/extra/http.good/authors.txt b/extra/http.good/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http.good/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http.good/basic-authentication/authors.txt b/extra/http.good/basic-authentication/authors.txt new file mode 100644 index 0000000000..44b06f94bc --- /dev/null +++ b/extra/http.good/basic-authentication/authors.txt @@ -0,0 +1 @@ +Chris Double diff --git a/extra/http.good/basic-authentication/basic-authentication-docs.factor b/extra/http.good/basic-authentication/basic-authentication-docs.factor new file mode 100644 index 0000000000..68d6e6bf1d --- /dev/null +++ b/extra/http.good/basic-authentication/basic-authentication-docs.factor @@ -0,0 +1,69 @@ +! 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 new file mode 100644 index 0000000000..318123b0b4 --- /dev/null +++ b/extra/http.good/basic-authentication/basic-authentication-tests.factor @@ -0,0 +1,66 @@ +! 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 new file mode 100644 index 0000000000..e15ba9db16 --- /dev/null +++ b/extra/http.good/basic-authentication/basic-authentication.factor @@ -0,0 +1,65 @@ +! 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 new file mode 100644 index 0000000000..60cef7e630 --- /dev/null +++ b/extra/http.good/basic-authentication/summary.txt @@ -0,0 +1 @@ +HTTP Basic Authentication implementation diff --git a/extra/http.good/basic-authentication/tags.txt b/extra/http.good/basic-authentication/tags.txt new file mode 100644 index 0000000000..c0772185a0 --- /dev/null +++ b/extra/http.good/basic-authentication/tags.txt @@ -0,0 +1 @@ +web diff --git a/extra/http.good/client/authors.txt b/extra/http.good/client/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http.good/client/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http.good/client/client-tests.factor b/extra/http.good/client/client-tests.factor new file mode 100755 index 0000000000..5e407657a8 --- /dev/null +++ b/extra/http.good/client/client-tests.factor @@ -0,0 +1,26 @@ +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 new file mode 100755 index 0000000000..8b74b6dc72 --- /dev/null +++ b/extra/http.good/client/client.factor @@ -0,0 +1,96 @@ +! 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 new file mode 100644 index 0000000000..5609c916c4 --- /dev/null +++ b/extra/http.good/client/summary.txt @@ -0,0 +1 @@ +HTTP client diff --git a/extra/http.good/client/tags.txt b/extra/http.good/client/tags.txt new file mode 100644 index 0000000000..93e65ae758 --- /dev/null +++ b/extra/http.good/client/tags.txt @@ -0,0 +1,2 @@ +web +network diff --git a/extra/http.good/http-tests.factor b/extra/http.good/http-tests.factor new file mode 100755 index 0000000000..9fa593053c --- /dev/null +++ b/extra/http.good/http-tests.factor @@ -0,0 +1,115 @@ +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 new file mode 100755 index 0000000000..4c2834b7ca --- /dev/null +++ b/extra/http.good/http.factor @@ -0,0 +1,277 @@ +! 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 new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http.good/mime/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http.good/mime/mime.factor b/extra/http.good/mime/mime.factor new file mode 100644 index 0000000000..3365127d87 --- /dev/null +++ b/extra/http.good/mime/mime.factor @@ -0,0 +1,34 @@ +! 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 new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/http.good/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/http.good/server/server-tests.factor b/extra/http.good/server/server-tests.factor new file mode 100755 index 0000000000..a67d21a640 --- /dev/null +++ b/extra/http.good/server/server-tests.factor @@ -0,0 +1,45 @@ +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 new file mode 100755 index 0000000000..e06ae6a95c --- /dev/null +++ b/extra/http.good/server/server.factor @@ -0,0 +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 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 new file mode 100644 index 0000000000..e6d2ca62e9 --- /dev/null +++ b/extra/http.good/server/summary.txt @@ -0,0 +1 @@ +HTTP server diff --git a/extra/http.good/server/tags.txt b/extra/http.good/server/tags.txt new file mode 100644 index 0000000000..b0881a9ec0 --- /dev/null +++ b/extra/http.good/server/tags.txt @@ -0,0 +1,3 @@ +enterprise +network +web diff --git a/extra/http.good/server/templating/authors.txt b/extra/http.good/server/templating/authors.txt new file mode 100644 index 0000000000..b47eafb62a --- /dev/null +++ b/extra/http.good/server/templating/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Matthew Willis diff --git a/extra/http.good/server/templating/templating-tests.factor b/extra/http.good/server/templating/templating-tests.factor new file mode 100644 index 0000000000..d889cd848a --- /dev/null +++ b/extra/http.good/server/templating/templating-tests.factor @@ -0,0 +1,17 @@ +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 new file mode 100755 index 0000000000..f364b86524 --- /dev/null +++ b/extra/http.good/server/templating/templating.factor @@ -0,0 +1,96 @@ +! 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 new file mode 100644 index 0000000000..cb66599079 --- /dev/null +++ b/extra/http.good/server/templating/test/bug.fhtml @@ -0,0 +1,5 @@ +<% + 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 new file mode 100644 index 0000000000..51d7b8d169 --- /dev/null +++ b/extra/http.good/server/templating/test/bug.html @@ -0,0 +1,2 @@ +5 + diff --git a/extra/http.good/server/templating/test/example.fhtml b/extra/http.good/server/templating/test/example.fhtml new file mode 100644 index 0000000000..211f44af9a --- /dev/null +++ b/extra/http.good/server/templating/test/example.fhtml @@ -0,0 +1,8 @@ +<% 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 new file mode 100644 index 0000000000..9bf4a08209 --- /dev/null +++ b/extra/http.good/server/templating/test/example.html @@ -0,0 +1,9 @@ + + + + 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 new file mode 100644 index 0000000000..399711a209 --- /dev/null +++ b/extra/http.good/server/templating/test/stack.fhtml @@ -0,0 +1 @@ +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 new file mode 100644 index 0000000000..ee923a6421 --- /dev/null +++ b/extra/http.good/server/templating/test/stack.html @@ -0,0 +1,2 @@ +The stack: + diff --git a/extra/http.good/summary.txt b/extra/http.good/summary.txt new file mode 100644 index 0000000000..8791a6f1c4 --- /dev/null +++ b/extra/http.good/summary.txt @@ -0,0 +1 @@ +Common code shared by HTTP client and server diff --git a/extra/http.good/tags.txt b/extra/http.good/tags.txt new file mode 100644 index 0000000000..93e65ae758 --- /dev/null +++ b/extra/http.good/tags.txt @@ -0,0 +1,2 @@ +web +network diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 34065203f8..1678c2de41 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -49,7 +49,7 @@ M: simple-monitor set-timeout set-simple-monitor-timeout ; >r r> construct-delegate ; inline : notify-callback ( simple-monitor -- ) - simple-monitor-callback ?box [ resume ] [ drop ] if ; + simple-monitor-callback [ resume ] if-box? ; M: simple-monitor timed-out notify-callback ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index b5ab63c4c8..9d6e95c07a 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -358,7 +358,6 @@ M: windows-ui-backend (close-window) { [ t ] [ dup TranslateMessage drop dup DispatchMessage drop - yield event-loop ] } } cond ; @@ -454,12 +453,11 @@ M: windows-ui-backend raise-window* ( world -- ) win-hWnd SetFocus drop ] when* ; -M: windows-ui-backend set-title ( string world -- ) - world-handle [ nip win-hWnd WM_SETTEXT 0 ] 2keep +M: windows-ui-backend set-title ( string handle -- ) dup win-title [ free ] when* - >r malloc-u16-string dup r> - set-win-title alien-address - SendMessage drop ; + >r malloc-u16-string r> + 2dup set-win-title + win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ; M: windows-ui-backend ui [ diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor index 32a104687e..78e2339764 100755 --- a/extra/vocabs/monitor/monitor.factor +++ b/extra/vocabs/monitor/monitor.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel -tools.browser namespaces continuations ; +tools.browser namespaces continuations vocabs.loader ; IN: vocabs.monitor ! Use file system change monitoring to flush the tags/authors @@ -9,7 +9,9 @@ IN: vocabs.monitor SYMBOL: vocab-monitor : monitor-thread ( -- ) - vocab-monitor get-global next-change 2drop reset-cache ; + vocab-monitor get-global + next-change 2drop + t sources-changed? set-global reset-cache ; : start-monitor-thread #! Silently ignore errors during monitor creation since