[Gd-chatter] r11478 - trunk/libraries/network/koala/sources/koala
turbo24prg at gwydiondylan.org
turbo24prg at gwydiondylan.org
Mon Oct 29 20:56:07 CET 2007
Author: turbo24prg
Date: Mon Oct 29 20:56:06 2007
New Revision: 11478
Modified:
trunk/libraries/network/koala/sources/koala/dsp-taglib.dylan
trunk/libraries/network/koala/sources/koala/dsp.dylan
trunk/libraries/network/koala/sources/koala/koala.lid
trunk/libraries/network/koala/sources/koala/library-unix.dylan
trunk/libraries/network/koala/sources/koala/responders.dylan
trunk/libraries/network/koala/sources/koala/server.dylan
trunk/libraries/network/koala/sources/koala/static-files.dylan
Log:
Job: koala
fix to the respond-to API
Modified: trunk/libraries/network/koala/sources/koala/dsp-taglib.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/dsp-taglib.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/dsp-taglib.dylan Mon Oct 29 20:56:06 2007
@@ -21,9 +21,9 @@
// </dsp:if>
//
define body tag \if in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
+ (page :: <dylan-server-page>, do-body :: <function>)
(test :: <named-method>)
- dynamic-bind (*if-tag-test-result* = test(page, get-request(response)))
+ dynamic-bind (*if-tag-test-result* = test(page))
// always process the body since there may be HTML outside the dsp:then
// or dsp:else tags.
do-body();
@@ -31,7 +31,7 @@
end;
define body tag \then in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
+ (page :: <dylan-server-page>, do-body :: <function>)
()
when (*if-tag-test-result* & (*if-tag-test-result* ~= #"unbound"))
do-body();
@@ -39,7 +39,7 @@
end;
define body tag \else in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
+ (page :: <dylan-server-page>, do-body :: <function>)
()
unless (*if-tag-test-result*)
do-body();
@@ -51,9 +51,9 @@
// </dsp:when>
//
define body tag \when in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
+ (page :: <dylan-server-page>, do-body :: <function>)
(test :: <named-method>)
- when (test(page, get-request(response)))
+ when (test(page))
do-body();
end;
end;
@@ -63,116 +63,23 @@
// </dsp:unless>
//
define body tag \unless in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
+ (page :: <dylan-server-page>, do-body :: <function>)
(test :: <named-method>)
- unless (test(page, get-request(response)))
+ unless (test(page))
do-body();
end;
end;
-//// Iteration tags
-
-define thread variable *table-has-rows?* :: <boolean> = #f;
-define thread variable *table-first-row?* :: <boolean> = #f;
-define thread variable *table-row-data* :: <object> = #f;
-define thread variable *table-row-number* :: <integer> = -1;
-
-define function current-row () *table-row-data* end;
-define function current-row-number () *table-row-number* end;
-
-define body tag table in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
- (generator :: <named-method>)
- let stream = output-stream(response);
- write(stream, "<table");
- show-tag-call-attributes(stream, exclude: #[#"generator"]);
- write(stream, ">\n");
- let (rows, start-index, row-count) = generator(page);
- let len = size(rows);
- if (len == 0 | row-count == 0)
- dynamic-bind(*table-has-rows?* = #f,
- *table-first-row?* = #t) // so that dsp:hrow will execute
- do-body();
- end;
- else
- let start :: <integer> = start-index | 0;
- for (i from start below start + (row-count | len),
- first-row? = #t then #f,
- while: i < len)
- dynamic-bind (*table-has-rows?* = #t,
- *table-row-data* = rows[i],
- *table-row-number* = i,
- *table-first-row?* = first-row?)
- do-body();
- end;
- end;
- end if;
- write(stream, "</table>");
-end;
-
-define body tag hrow in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
- ()
- when (*table-first-row?*)
- show-table-element(output-stream(response), "tr", do-body);
- end;
-end;
-
-define body tag row in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
- ()
- when (*table-has-rows?*)
- show-table-element(output-stream(response), "tr", do-body);
- end;
-end;
-
-define body tag hcell in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
- ()
- show-table-element(output-stream(response), "td", do-body);
-end;
-
-define body tag cell in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
- ()
- show-table-element(output-stream(response), "td", do-body);
-end;
-
-define body tag no-rows in dsp
- (page :: <dylan-server-page>, response :: <response>, do-body :: <function>)
- ()
- when (~ *table-has-rows?*)
- show-table-element(output-stream(response), "tr", do-body);
- end;
-end;
-
-define function show-table-element
- (stream, element-name :: <string>, do-body :: <function>)
- format(stream, "<%s", element-name);
- show-tag-call-attributes(stream);
- write(stream, ">");
- do-body();
- format(stream, "</%s>", element-name);
-end;
-
-define tag row-number in dsp
- (page :: <dylan-server-page>, response :: <response>)
- ()
- when (*table-row-number* >= 0)
- format(output-stream(response), "%d", *table-row-number* + 1);
- end;
-end;
// ---TODO: Define a tag to replace the HTML <input> tag, that will automatically take
// care of defaulting the value correctly if the form is redisplayed due to
// error, and will allow CSS to display the input tag in a unique way.
//
-define tag show-query-value in dsp
- (page :: <dylan-server-page>, response :: <response>)
- (name :: <string>)
+define tag show-query-value in dsp (page :: <dylan-server-page>)
+ (name :: <string>)
let qv = get-query-value(name);
- qv & write(output-stream(response), qv);
+ qv & write(current-response().output-stream, qv);
end;
@@ -183,114 +90,20 @@
// and style.
// @see parse-tag-arg(<string>, <date>)
//
-define tag show-date in dsp
- (page :: <dylan-server-page>, response :: <response>)
- (timezone, style, date :: <date> = current-date(), key, scope)
+define tag show-date in dsp (page :: <dylan-server-page>)
+ (timezone, style, date :: <date> = current-date(), key, scope)
//---TODO: Finish this. For now it can only show the current date.
- date-to-stream(output-stream(response), date);
+ date-to-stream(current-response().output-stream, date);
end;
//// HTTP Header Tags
-define tag show-referer in dsp
- (page :: <dylan-server-page>, response :: <response>)
- ()
- format(output-stream(response), "%s",
+define tag show-referer in dsp (page :: <dylan-server-page>)
+ ()
+ format(current-response().output-stream, "%s",
header-value(#"Referer"));
end;
//// Internationalization tags
//// XML tags
-
-
-
-// A simple error reporting mechanism. Store errors in the page context
-// so they can be displayed when the next page is generated. The idea is
-// that pages should use the <dsp:show-errors/> tag if they can be
-// the target of a GET or POST that might generate errors.
-
-define abstract class <form-note> (<object>)
- constant slot format-string :: <string>,
- required-init-keyword: #"format-string";
- constant slot format-arguments :: <sequence>,
- required-init-keyword: #"format-arguments";
-end;
-
-define class <form-error> (<form-note>)
- constant slot form-field-name :: false-or(<string>) = #f,
- init-keyword: #"form-field-name";
-end;
-
-define class <form-message> (<form-note>)
-end;
-
-define method note-form-error
- (message :: <string>, #rest args, #key field)
- add-form-note(make(<form-error>,
- format-string: message,
- format-arguments: remove-keys(args, #"field"),
- form-field-name: field))
-end;
-
-define method note-form-message
- (message :: <string>, #rest args)
- add-form-note(make(<form-message>,
- format-string: message,
- format-arguments: copy-sequence(args)));
-end;
-
-define constant $form-notes-key = #"form-notes";
-
-// This shows the use of <page-context> to store the form errors since they
-// only need to be accessible during the processing of one page.
-//
-define method add-form-note
- (note :: <form-note>)
- let context :: <page-context> = page-context();
- let notes = get-attribute(context, $form-notes-key) | make(<stretchy-vector>);
- add!(notes, note);
- set-attribute(context, $form-notes-key, notes);
-end;
-
-define method display-form-note
- (out :: <stream>, note :: <form-error>)
- write(out, "<li>");
- // Should I call quote-html on this output?
- apply(format, out, format-string(note), format-arguments(note));
- write(out, "</li>\n");
-end;
-
-define method display-form-note
- (out :: <stream>, note :: <form-message>)
- write(out, "<p>");
- // Should I call quote-html on this output?
- apply(format, out, format-string(note), format-arguments(note));
- write(out, "</p>\n");
-end;
-
-define tag show-form-notes in dsp
- (page :: <dylan-server-page>, response :: <response>)
- ()
- let notes = get-attribute(page-context(), $form-notes-key);
- when (notes)
- let messages = choose(rcurry(instance?, <form-message>), notes);
- let errors = choose(rcurry(instance?, <form-error>), notes);
- let out = output-stream(response);
- write(out, "<div class=\"form-notes\">\n");
- unless(empty?(messages))
- write(out, "<div class=\"form-note-message\">\n");
- do(curry(display-form-note, out), messages);
- write(out, "</div>\n");
- end;
- unless(empty?(errors))
- format(out, "<div class=\"form-note-errors\">Please fix the following errors:\n<ul>\n");
- do(curry(display-form-note, out), errors);
- format(out, "</ul></div>\n");
- end;
- write(out, "</div>\n");
- end;
-end;
-
-
-
Modified: trunk/libraries/network/koala/sources/koala/dsp.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/dsp.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/dsp.dylan Mon Oct 29 20:56:06 2007
@@ -74,59 +74,23 @@
end;
// The protocol every page needs to support.
-define open generic respond-to-get (page :: <page>, request :: <request>, response :: <response>);
-define open generic respond-to-post (page :: <page>, request :: <request>, response :: <response>);
-define open generic respond-to-head (page :: <page>, request :: <request>, response :: <response>);
-
-// Default methods do nothing.
-define method respond-to-get (page :: <page>, request :: <request>, response :: <response>) end;
-define method respond-to-head (page :: <page>, request :: <request>, response :: <response>) end;
-define method respond-to-post (page :: <page>, request :: <request>, response :: <response>)
- respond-to-get(page, request, response);
-end;
-
// This is the method registered as the response function for all <page>s.
// See register-page.
-define method process-page (page :: <page>,
- request :: <request>,
- response :: <response>)
- let pc = make(<page-context>);
- dynamic-bind (*page-context* = pc)
- respond-to(request.request-method, page, request, response);
+define method process-page (page :: <page>)
+ let page-context = make(<page-context>);
+ dynamic-bind (*page-context* = page-context)
+ respond-to(current-request().request-method, page);
end;
end process-page;
-define open generic respond-to
- (request-method :: <symbol>, page :: <page>, request :: <request>, response :: <response>);
+define open generic respond-to (request-method :: <symbol>, page :: <page>);
-define method respond-to
- (request-method :: <symbol>, page :: <page>, request :: <request>, response :: <response>)
- unsupported-request-method-error()
-end;
-
-define method respond-to
- (request-method == #"GET", page :: <page>, request :: <request>, response :: <response>)
- respond-to-get(page, request, response);
-end;
-
-define method respond-to
- (request-method == #"POST", page :: <page>, request :: <request>, response :: <response>)
- respond-to-post(page, request, response);
-end;
-
-define method respond-to
- (request-method == #"HEAD", page :: <page>, request :: <request>, response :: <response>)
- respond-to-head(page, request, response);
-end;
+define method respond-to (request-method :: one-of(#"get", #"post"), page :: <page>)
+ process-template(page);
+end;
-// What do these two methods buy us? It's hard to find callers
-// of such short method names too. --cgay
-define method post (page :: <page>)
- respond-to(#"post", page, current-request(), current-response());
-end;
-
-define method get (page :: <page>)
- respond-to(#"get", page, current-request(), current-response());
+define method respond-to (request-method :: <symbol>, page :: <page>)
+ unsupported-request-method-error();
end;
// Applications should call this to register a page for a particular URL.
@@ -256,19 +220,18 @@
define open primary class <static-page> (<file-page-mixin>, <page>)
end;
-define method respond-to-get
- (page :: <static-page>, request :: <request>, response :: <response>)
+define method respond-to (request-method == #"get", page :: <static-page>)
if (page-source-modified?(page))
page.mod-time := file-property(source-location(page),
#"modification-date");
page.contents := file-contents(source-location(page));
end if;
if (page.contents)
- let stream = output-stream(response);
+ let stream = output-stream(current-response());
write(stream, page.contents);
force-output(stream);
else
- resource-not-found-error(url: request-url(request));
+ resource-not-found-error(url: current-request().request-url);
end;
end;
@@ -590,17 +553,16 @@
end;
end;
-define method execute
- (call :: <tag-call>, page, request, response);
+define method execute (call :: <tag-call>, page);
let tag :: <tag> = call.tag;
// Might consider wrapping do-body in a method that logs a warning if the tag
// isn't supposed to allow a body but one was supplied.
let do-body
= iff(call.body,
- curry(display-template, call.body, page, request, response),
+ curry(display-template, call.body, page),
method () end);
dynamic-bind (*tag-call* = call)
- apply(tag.tag-function, page, response, do-body, call.arguments);
+ apply(tag.tag-function, page, do-body, call.arguments);
end;
end;
@@ -686,6 +648,7 @@
=> { page-aux(?name; ?superclasses; ?make-args; ?slot-specs);
has-url?(?make-args) & register-page-urls("*" ## ?name ## "*", ?make-args, prefix?: #t)
}
+
end;
define macro page-aux
@@ -725,21 +688,21 @@
// not display the body (if there is one), which might be very hard to debug, or
// to make the user remember to deal with the body in each tag.
{ define tag ?tag:name ?taglib-spec
- (?page:variable, ?response:variable) (?tag-parameters:*)
+ (?page:variable) (?tag-parameters:*)
?:body
end }
=> { define tag-aux #f ?tag ?taglib-spec
- (?page, ?response, _do-body) (?tag-parameters)
+ (?page, _do-body) (?tag-parameters)
?body; // semicolon is needed even when ?body ends in semicolon.
_do-body(); // process the tag body
end
}
{ define body tag ?tag:name ?taglib-spec
- (?page:variable, ?response:variable, ?do-body:variable) (?tag-parameters:*)
+ (?page:variable, ?do-body:variable) (?tag-parameters:*)
?:body
end }
=> { define tag-aux #t ?tag ?taglib-spec
- (?page, ?response, ?do-body) (?tag-parameters)
+ (?page, ?do-body) (?tag-parameters)
?body
end
}
@@ -753,11 +716,11 @@
define macro tag-aux-definer
{ define tag-aux ?allow-body:expression ?tag:name ?taglib:name
- (?page:variable, ?response:variable, ?do-body:variable)
+ (?page:variable, ?do-body:variable)
(?tag-parameters:*)
?:body
end }
- => { define method ?tag ## "-tag" (?page, ?response, ?do-body, #key ?tag-parameters, #all-keys)
+ => { define method ?tag ## "-tag" (?page, ?do-body, #key ?tag-parameters, #all-keys)
?body
end;
register-tag(make(<tag>,
@@ -805,9 +768,9 @@
end;
define body tag %%placeholder-for-unparsable-tags in dsp
- (page :: <dylan-server-page>, response :: <response>, process-body :: <function>)
+ (page :: <dylan-server-page>, process-body :: <function>)
()
- format(output-stream(response), " TAG PARSE ERROR ");
+ format(current-response().output-stream, " TAG PARSE ERROR ");
process-body();
end;
@@ -827,43 +790,35 @@
// the result. Subclasses can either call this with next-method() or call
// process-template explicitly.
//
-define method respond-to-get
- (page :: <dylan-server-page>, request :: <request>, response :: <response>)
- process-template(page, request, response);
-end;
// Subclasses of <dylan-server-page> can call this in their respond-to-get/post
// methods if they decide they want the DSP template to be processed. (They
// may also skip template processing by calling some other respond-to-get/post
// method, throwing an exception, etc.
//
-define open method process-template
- (page :: <dylan-server-page>, request :: <request>, response :: <response>)
+define open method process-template (page :: <dylan-server-page>)
when (page-source-modified?(page) | ~ slot-initialized?(page, page-template))
page.mod-time := file-property(source-location(page),
#"modification-date");
page.page-template := parse-page(page);
end;
- display-template(page.page-template, page, request, response);
+ display-template(page.page-template, page);
end;
-define method display-template (tmplt :: <dsp-template>,
- page :: <dylan-server-page>,
- request :: <request>,
- response :: <response>)
+define method display-template (tmplt :: <dsp-template>, page :: <dylan-server-page>)
log-debug("Displaying template %=", tmplt);
- let stream = output-stream(response);
+ let stream = current-response().output-stream;
for (item in tmplt.entries)
select (item by instance?)
<string>
=> write(stream, item);
// A subtemplate is created for tag bodies and for the "include" directive.
<dsp-template>
- => display-template(item, page, request, response);
+ => display-template(item, page);
<function>
- => item(page, request, response);
+ => item(page);
<tag-call>
- => execute(item, page, request, response);
+ => execute(item, page);
otherwise
=> signal(make(<dsp-error>,
format-string: "Invalid DSP template element"));
@@ -1252,11 +1207,6 @@
end iterate
end extract-tag-args;
-define method respond-to-head
- (page :: <dylan-server-page>, request :: <request>, response :: <response>)
- //---*** TODO
-end;
-
//// Configuration
@@ -1266,5 +1216,3 @@
register-page(url, make(<dylan-server-page>,
source: document-location(url)))
end;
-
-
Modified: trunk/libraries/network/koala/sources/koala/koala.lid
==============================================================================
--- trunk/libraries/network/koala/sources/koala/koala.lid (original)
+++ trunk/libraries/network/koala/sources/koala/koala.lid Mon Oct 29 20:56:06 2007
@@ -21,7 +21,6 @@
dsp-taglib
database
records
- pages
xml-rpc-server
config
responders
Modified: trunk/libraries/network/koala/sources/koala/library-unix.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/library-unix.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/library-unix.dylan Mon Oct 29 20:56:06 2007
@@ -390,12 +390,7 @@
<static-page>,
register-page, // Register a page for a given URL
url-to-page,
- respond-to-get, // Implement this for your page to handle GET requests
- respond-to-post, // Implement this for your page to handle POST requests
- respond-to-head, // Implement this for your page to handle HEAD requests
- respond-to, // Implement this for other request methods
- get, // convenience
- post, // convenience
+ respond-to, // Implement this for you page to handle a request
page-source,
page-source-setter,
Modified: trunk/libraries/network/koala/sources/koala/responders.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/responders.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/responders.dylan Mon Oct 29 20:56:06 2007
@@ -6,13 +6,12 @@
License: Functional Objects Library Public License Version 1.0
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-
+/*
// General server statistics
//
define responder general-stats-responder ("/koala/stats")
- (request, response)
- let stream = output-stream(response);
- let server = request.request-server;
+ let stream = current-response().output-stream;
+ let server = current-request().request-server;
format(stream, "<html><body>");
format(stream, "%s<br>", $server-header-value);
format(stream, "Up since %s<br>", as-iso8601-string(server.startup-date));
@@ -24,10 +23,9 @@
// Show some stats about what user-agents have connected to the server.
//
define responder user-agent-responder ("/koala/user-agents")
- (request, response)
- let stream = output-stream(response);
+ let stream = current-response().output-stream;
format(stream, "<html><body>");
- for (count keyed-by agent in user-agent-stats(request-server(request)))
+ for (count keyed-by agent in current-request().request-server.user-agent-stats)
format(stream, "%5d: %s<br>", count, agent);
end;
format(stream, "</body></html>");
@@ -37,7 +35,6 @@
// e.g., /koala/http-error?code=503
//
define responder http-error-responder ("/koala/http-error")
- (request, response)
let code-string = get-query-value("code");
let code = string-to-integer(code-string);
signal(make(<http-error>,
@@ -45,38 +42,4 @@
format-string: "Koala HTTP server received a request for error code %=",
format-arguments: vector(code-string)));
end;
-
-// Load a module
-//
-define responder load-module-responder ("/koala/load-module")
- (request, response)
- load/unload-module(request, response, #"load");
-end;
-
-// Unload a module
-//
-define responder unload-module-responder ("/koala/unload-module")
- (request, response)
- load/unload-module(request, response, #"unload");
-end;
-
-define function load/unload-module
- (request :: <request>, response :: <response>, op :: one-of(#"load", #"unload"))
- let stream = output-stream(response);
- let server = request.request-server;
- let module-name = get-query-value("name");
- write(stream, "<html><body>\n");
- if (~module-name)
- write(stream, "You must specify the name of a module in the URL.\n");
- else
- if (op == #"load")
- load-module(module-name);
- format(stream, "Module %s loaded.");
- else
- unload-module(module-name);
- format(stream, "Module %s unloaded.");
- end;
- end;
- write(stream, "</body></html>");
-end;
-
+*/
Modified: trunk/libraries/network/koala/sources/koala/server.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/server.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/server.dylan Mon Oct 29 20:56:06 2007
@@ -950,20 +950,18 @@
// end;
define macro responder-definer
{ define responder ?:name (?url:expression)
- (?request:variable, ?response:variable)
?:body
end
}
- => { define method ?name (?request, ?response) ?body end;
+ => { define method ?name () ?body end;
register-url(?url, ?name)
}
{ define directory responder ?:name (?url:expression)
- (?request:variable, ?response:variable)
?:body
end
}
- => { define method ?name (?request, ?response) ?body end;
+ => { define method ?name () ?body end;
register-url(?url, ?name, prefix?: #t)
}
end;
@@ -984,10 +982,10 @@
dynamic-bind (*response* = response)
if (request.request-responder)
log-debug("%s handler found", request-url(request));
- request.request-responder(request, response);
+ request.request-responder();
else
// generates 404 if not found
- maybe-serve-static-file(request, response);
+ maybe-serve-static-file();
end;
end;
send-response(response);
Modified: trunk/libraries/network/koala/sources/koala/static-files.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/static-files.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/static-files.dylan Mon Oct 29 20:56:06 2007
@@ -42,9 +42,9 @@
end block
end document-location;
-define method maybe-serve-static-file
- (request :: <request>, response :: <response>)
- => ()
+define method maybe-serve-static-file ()
+ let request = current-request();
+ let response = current-response();
let url :: <string> = request-url(request);
let document :: false-or(<physical-locator>)
= static-file-locator-from-url(url);
@@ -96,9 +96,9 @@
end;
end;
end;
- static-file-responder(request, response, target);
+ static-file-responder(target);
otherwise =>
- static-file-responder(request, response, document);
+ static-file-responder(document);
end select;
end if;
end method maybe-serve-static-file;
@@ -162,8 +162,8 @@
// Serves up a static file
-define method static-file-responder
- (request :: <request>, response :: <response>, locator :: <locator>)
+define method static-file-responder (locator :: <locator>)
+ let response = current-response();
with-open-file(in-stream = locator, direction: #"input", if-does-not-exist: #f,
element-type: <byte>)
let mime-type = get-mime-type(locator);
@@ -172,7 +172,7 @@
add-header(response, "Last-Modified",
as-rfc1123-string(props[#"modification-date"]));
//---TODO: optimize this
- write(output-stream(response), stream-contents(in-stream));
+ write(response.output-stream, stream-contents(in-stream));
end;
end;
More information about the chatter
mailing list