From 6a97831ba566cebab4b2f3c9bfffdab89e89ea3c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Sep 2008 22:42:57 -0500 Subject: [PATCH 1/8] Add example to docs --- basis/http/server/static/static-docs.factor | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/basis/http/server/static/static-docs.factor b/basis/http/server/static/static-docs.factor index 866d2a3409..bca72a6126 100644 --- a/basis/http/server/static/static-docs.factor +++ b/basis/http/server/static/static-docs.factor @@ -19,11 +19,7 @@ HELP: enable-fhtml { $notes "See " { $link "html.templates.fhtml" } "." } { $side-effects "responder" } ; -ARTICLE: "http.server.static" "Serving static content" -"The " { $vocab-link "http.server.static" } " vocabulary implements a responder for serving static files." -{ $subsection } -"The static responder does not serve directory listings by default, as a security measure. Directory listings can be enabled by storing a true value in the " { $slot "allow-listings" } " slot." -$nl +ARTICLE: "http.server.static.extend" "Hooks for dynamic content" "The static responder can be extended for dynamic content by associating quotations with MIME types in the hashtable stored in the " { $slot "special" } " slot. The quotations have stack effect " { $snippet "( path -- )" } "." $nl "A utility word uses the above feature to enable server-side " { $snippet ".fhtml" } " scripts, allowing a development style much like PHP:" @@ -34,4 +30,17 @@ $nl { $subsection } "The default just sends the file's contents with the request; " { $vocab-link "xmode.code2html.responder" } " provides an alternate hook which sends a syntax-highlighted version of the file." ; +ARTICLE: "http.server.static" "Serving static content" +"The " { $vocab-link "http.server.static" } " vocabulary implements a responder for serving static files." +{ $subsection } +"The static responder does not serve directory listings by default, as a security measure. Directory listings can be enabled by storing a true value in the " { $slot "allow-listings" } " slot." +$nl +"If all you want to do is serve files from a directory, the following phrase does the trick:" +{ $code + "USING: namespaces http.server http.server.static ;" + "/var/www/mysite.com/ main-responder set" + "8080 httpd" +} +{ $subsection "http.server.static.extend" } ; + ABOUT: "http.server.static" From ec95a0db6326c2d0502f575d71f8b50321a6e608 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Sep 2008 23:38:11 -0500 Subject: [PATCH 2/8] Fix erg's mouse drag bug --- basis/ui/gadgets/worlds/worlds.factor | 8 ++++---- basis/ui/gestures/gestures.factor | 6 ------ 2 files changed, 4 insertions(+), 10 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 1bdc63ed0e..6f901c37ee 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -101,10 +101,10 @@ world H{ { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] } { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] } { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] } - { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] } - { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] } - { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] } - { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] } + { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] } + { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] } + { T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] } + { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] } } set-gestures : close-global ( world global -- ) diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index a1c6adac6e..2a29d32055 100755 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -249,12 +249,6 @@ SYMBOL: drag-timer : send-action ( world gesture -- ) swap world-focus send-gesture drop ; -: resend-button-down ( gesture world -- ) - hand-loc get-global swap send-button-down ; - -: resend-button-up ( gesture world -- ) - hand-loc get-global swap send-button-up ; - GENERIC: gesture>string ( gesture -- string/f ) : modifiers>string ( modifiers -- string ) From 8cb3c1eb5e9b8070c595933c7634ea3a1da6ab85 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Oct 2008 03:12:35 -0500 Subject: [PATCH 3/8] Literal hashtables now cross-referenced --- core/words/words.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/words/words.factor b/core/words/words.factor index 5627a1a015..b7b34f1d22 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -87,6 +87,8 @@ M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ; M: array (quot-uses) seq-uses ; +M: hashtable (quot-uses) >r >alist r> seq-uses ; + M: callable (quot-uses) seq-uses ; M: wrapper (quot-uses) >r wrapped>> r> (quot-uses) ; From b546ad3c6d920a38ab83ee267b3c2da65e91c003 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Oct 2008 03:13:56 -0500 Subject: [PATCH 4/8] Fix problem odd headers sent by Windows CE --- basis/http/server/static/static.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 5ae18156b0..3e3307033a 100755 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -3,7 +3,7 @@ USING: calendar io io.files kernel math math.order math.parser namespaces parser sequences strings assocs hashtables debugger mime-types sorting logging -calendar.format accessors +calendar.format accessors splitting io.encodings.binary fry xml.entities destructors urls html.elements html.templates.fhtml http @@ -14,9 +14,13 @@ IN: http.server.static TUPLE: file-responder root hook special allow-listings ; +: modified-since ( request -- date ) + "if-modified-since" header ";" split1 drop + dup [ rfc822>timestamp ] when ; + : modified-since? ( filename -- ? ) - request get "if-modified-since" header dup [ - [ file-info modified>> ] [ rfc822>timestamp ] bi* after? + request get modified-since dup [ + [ file-info modified>> ] dip after? ] [ 2drop t ] if ; From c3f9d2180a63f6febd262e5966a931e63450d72f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Oct 2008 03:35:41 -0500 Subject: [PATCH 5/8] Fix typo --- core/classes/classes-docs.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index ff7aac36d3..f8a2ff415c 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -28,12 +28,13 @@ $nl $nl "Classes themselves form a class:" { $subsection class? } -"You can ask an object for its class or superclass:" +"You can ask an object for its class:" { $subsection class } -{ $subsection superclass } -{ $subsection superclasses } "Testing if an object is an instance of a class:" { $subsection instance? } +"You can ask a class for its superclass:" +{ $subsection superclass } +{ $subsection superclasses } "Class predicates can be used to test instances directly:" { $subsection "class-predicates" } "There is a universal class which all objects are an instance of, and an empty class with no instances:" From 1cf1d967ea7352870d57b951f8d68f21b2e53002 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Oct 2008 05:43:20 -0500 Subject: [PATCH 6/8] New combinators for incremental HTTP requests --- basis/http/client/client-docs.factor | 15 +++- basis/http/client/client-tests.factor | 3 + basis/http/client/client.factor | 114 +++++++++++++++----------- 3 files changed, 84 insertions(+), 48 deletions(-) diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor index ed846320c3..a762d1a5ef 100644 --- a/basis/http/client/client-docs.factor +++ b/basis/http/client/client-docs.factor @@ -39,11 +39,21 @@ HELP: http-post { $description "Submits a form at a URL." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: with-http-get +{ $values { "url" "a " { $link url } " or " { $link string } } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } } +{ $description "Downloads the contents of a URL. Chunks of data are passed to the quotation as they are read." } +{ $errors "Throws an error if the HTTP request fails." } ; + HELP: http-request { $values { "request" request } { "response" response } { "data" sequence } } { $description "Sends an HTTP request to an HTTP server, and reads the response." } { $errors "Throws an error if the HTTP request fails." } ; +HELP: with-http-request +{ $values { "request" request } { "quot" "a quotation with stack effect " { $snippet "( chunk -- )" } } { "response" response } } +{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." } +{ $errors "Throws an error if the HTTP request fails." } ; + ARTICLE: "http.client.get" "GET requests with the HTTP client" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:" { $subsection http-get } @@ -52,7 +62,10 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client" { $subsection download-to } "Advanced usage involves constructing a " { $link request } ", which allows " { $link "http.cookies" } " and " { $link "http.headers" } " to be set:" { $subsection } -{ $subsection http-request } ; +{ $subsection http-request } +"The " { $link http-get } " and " { $link http-request } " words output sequences. This is undesirable if the response data may be large. Another pair of words take a quotation instead, and pass the quotation chunks of data incrementally:" +{ $subsection with-http-get } +{ $subsection with-http-request } ; ARTICLE: "http.client.post" "POST requests with the HTTP client" "As with GET requests, there is a high-level word which takes a " { $link url } " and a lower-level word which constructs an HTTP request object which can be passed to " { $link http-request } ":" diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor index 1219ae0b97..4dcc6b8813 100755 --- a/basis/http/client/client-tests.factor +++ b/basis/http/client/client-tests.factor @@ -1,5 +1,8 @@ USING: http.client http.client.private http tools.test namespaces urls ; + +\ download must-infer + [ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor index 174c4e1b3a..aa1e0771ba 100755 --- a/basis/http/client/client.factor +++ b/basis/http/client/client.factor @@ -3,7 +3,7 @@ USING: accessors assocs kernel math math.parser namespaces make sequences io io.sockets io.streams.string io.files io.timeouts strings splitting calendar continuations accessors vectors -math.order hashtables byte-arrays prettyprint +math.order hashtables byte-arrays prettyprint destructors io.encodings io.encodings.string io.encodings.ascii @@ -88,72 +88,92 @@ M: too-many-redirects summary drop [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ; -DEFER: (http-request) - url derive-url ensure-port ] change-url ; -: do-redirect ( response data -- response data ) - over code>> 300 399 between? [ - drop - redirects inc - redirects get max-redirects < [ - request get - swap "location" header redirect-url - "GET" >>method (http-request) - ] [ - too-many-redirects - ] if - ] when ; +: redirect? ( response -- ? ) + code>> 300 399 between? ; -PRIVATE> +: do-redirect ( quot: ( chunk -- ) response -- response ) + redirects inc + redirects get max-redirects < [ + request get clone + swap "location" header redirect-url + "GET" >>method swap (with-http-request) + ] [ too-many-redirects ] if ; inline recursive : read-chunk-size ( -- n ) read-crlf ";" split1 drop [ blank? ] trim-right hex> [ "Bad chunk size" throw ] unless* ; -: read-chunks ( -- ) +: read-chunked ( quot: ( chunk -- ) -- ) read-chunk-size dup zero? - [ drop ] [ read % read-crlf B{ } assert= read-chunks ] if ; + [ 2drop ] [ + read [ swap call ] [ drop ] 2bi + read-crlf B{ } assert= read-chunked + ] if ; inline recursive -: read-response-body ( response -- response data ) - dup "transfer-encoding" header "chunked" = [ - binary decode-input - [ read-chunks ] B{ } make - over content-charset>> decode - ] [ - dup content-charset>> decode-input - input-stream get contents - ] if ; +: read-unchunked ( quot: ( chunk -- ) -- ) + 8192 read dup [ + [ swap call ] [ drop read-unchunked ] 2bi + ] [ 2drop ] if ; inline recursive -: (http-request) ( request -- response data ) - dup request [ - dup url>> url-addr ascii [ - 1 minutes timeouts - write-request - read-response - read-response-body - ] with-client - do-redirect - ] with-variable ; +: read-response-body ( quot response -- ) + binary decode-input + "transfer-encoding" header "chunked" = + [ read-chunked ] [ read-unchunked ] if ; inline + +: ( -- stream ) + request get url>> url-addr ascii drop + 1 minutes over set-timeout ; + +: (with-http-request) ( request quot: ( chunk -- ) -- response ) + swap + request [ + [ + [ + out>> + [ request get write-request ] + with-output-stream* + ] [ + in>> [ + read-response dup redirect? [ t ] [ + [ nip response set ] + [ read-response-body ] + [ ] + 2tri f + ] if + ] with-input-stream* + ] bi + ] with-disposal + [ do-redirect ] [ nip ] if + ] with-variable ; inline recursive + +PRIVATE> : success? ( code -- ? ) 200 = ; -ERROR: download-failed response body ; +ERROR: download-failed response ; M: download-failed error. - "HTTP download failed:" print nl - [ response>> . nl ] [ body>> write ] bi ; + "HTTP request failed:" print nl + response>> . ; -: check-response ( response data -- response data ) - over code>> success? [ download-failed ] unless ; +: check-response ( response -- response ) + dup code>> success? [ download-failed ] unless ; + +: with-http-request ( request quot -- response ) + (with-http-request) check-response ; inline : http-request ( request -- response data ) - (http-request) check-response ; + [ [ % ] with-http-request ] B{ } make + over content-charset>> decode ; : ( url -- request ) @@ -163,14 +183,14 @@ M: download-failed error. : http-get ( url -- response data ) http-request ; +: with-http-get ( url quot -- response ) + [ ] dip with-http-request ; inline + : download-name ( url -- name ) present file-name "?" split1 drop "/" ?tail drop ; : download-to ( url file -- ) - #! Downloads the contents of a URL to a file. - swap http-get - [ content-charset>> ] [ '[ _ write ] ] bi* - with-file-writer ; + binary [ [ write ] with-http-get drop ] with-file-writer ; : download ( url -- ) dup download-name download-to ; From 34952ff5c4f1a09e3b319a55a112e95e6865298d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Oct 2008 08:20:49 -0500 Subject: [PATCH 7/8] Faster call-next-method --- basis/bootstrap/image/image.factor | 2 +- core/classes/classes.factor | 7 +++++-- core/generic/generic.factor | 13 ++++++++----- 3 files changed, 14 insertions(+), 8 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index f3f570b462..db8e8c8ec0 100755 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -417,7 +417,7 @@ M: quotation ' } [ [ bootstrap-word ] [ get ] bi ] H{ } map>assoc { class<=-cache class-not-cache classes-intersect-cache - class-and-cache class-or-cache + class-and-cache class-or-cache next-method-quot-cache } [ H{ } clone ] H{ } map>assoc assoc-union bootstrap-global set bootstrap-global emit-userenv ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 67a789a1dc..dcb69c9149 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -10,20 +10,23 @@ SYMBOL: class-not-cache SYMBOL: classes-intersect-cache SYMBOL: class-and-cache SYMBOL: class-or-cache +SYMBOL: next-method-quot-cache : init-caches ( -- ) H{ } clone class<=-cache set H{ } clone class-not-cache set H{ } clone classes-intersect-cache set H{ } clone class-and-cache set - H{ } clone class-or-cache set ; + H{ } clone class-or-cache set + H{ } clone next-method-quot-cache set ; : reset-caches ( -- ) class<=-cache get clear-assoc class-not-cache get clear-assoc classes-intersect-cache get clear-assoc class-and-cache get clear-assoc - class-or-cache get clear-assoc ; + class-or-cache get clear-assoc + next-method-quot-cache get clear-assoc ; SYMBOL: update-map diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 026e372912..d25a98c53c 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -45,7 +45,9 @@ GENERIC: effective-method ( generic -- method ) GENERIC: next-method-quot* ( class generic combination -- quot ) : next-method-quot ( class generic -- quot ) - dup "combination" word-prop next-method-quot* ; + next-method-quot-cache get [ + dup "combination" word-prop next-method-quot* + ] 2cache ; : (call-next-method) ( class generic -- ) next-method-quot call ; @@ -99,10 +101,11 @@ M: method-body crossref? 2bi ; : create-method ( class generic -- method ) - 2dup method dup [ - 2nip - ] [ - drop [ dup ] 2keep reveal-method + 2dup method dup [ 2nip ] [ + drop + [ dup ] 2keep + reveal-method + reset-caches ] if ; PREDICATE: default-method < word "default" word-prop ; From e1a2bfc048e92319a9cfc0da366bcc1641834e6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 1 Oct 2008 08:38:50 -0500 Subject: [PATCH 8/8] Oops --- core/generic/generic-tests.factor | 14 ++++++++++++++ core/generic/generic.factor | 4 ++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 22c690ffaf..aae76184ff 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -222,3 +222,17 @@ M: integer a-generic a-word ; M: boii jeah ; "> eval ] unit-test + +! call-next-method cache test +GENERIC: c-n-m-cache ( a -- b ) + +! Force it to be unoptimized +M: fixnum c-n-m-cache { } [ ] like call call-next-method ; +M: integer c-n-m-cache 1 + ; +M: number c-n-m-cache ; + +[ 3 ] [ 2 c-n-m-cache ] unit-test + +[ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test + +[ 2 ] [ 2 c-n-m-cache ] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index d25a98c53c..095a8d5dcc 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -152,8 +152,8 @@ M: method-body forget* ] keep eq? [ [ [ delete-at ] with-methods ] - [ [ delete-at ] with-implementors ] - 2bi + [ [ delete-at ] with-implementors ] 2bi + reset-caches ] [ 2drop ] if ] if ]