[Gd-chatter] r11682 - in trunk/libraries/network/koala: config sources/dylan-basics sources/koala
turbo24prg at gwydiondylan.org
turbo24prg at gwydiondylan.org
Sun Feb 17 19:09:47 CET 2008
Author: turbo24prg
Date: Sun Feb 17 19:09:45 2008
New Revision: 11682
Added:
trunk/libraries/network/koala/sources/koala/modules.dylan (contents, props changed)
Modified:
trunk/libraries/network/koala/config/koala-config.xml
trunk/libraries/network/koala/sources/dylan-basics/dylan-basics.dylan
trunk/libraries/network/koala/sources/dylan-basics/library.dylan
trunk/libraries/network/koala/sources/koala/config.dylan
trunk/libraries/network/koala/sources/koala/dsp-main.dylan
trunk/libraries/network/koala/sources/koala/dsp.dylan
trunk/libraries/network/koala/sources/koala/koala-unix.lid
trunk/libraries/network/koala/sources/koala/koala.lid
trunk/libraries/network/koala/sources/koala/library-unix.dylan
trunk/libraries/network/koala/sources/koala/library.dylan
trunk/libraries/network/koala/sources/koala/log.dylan
trunk/libraries/network/koala/sources/koala/responders.dylan
trunk/libraries/network/koala/sources/koala/response.dylan
trunk/libraries/network/koala/sources/koala/server.dylan
trunk/libraries/network/koala/sources/koala/static-files.dylan
trunk/libraries/network/koala/sources/koala/urls.dylan
trunk/libraries/network/koala/sources/koala/utils.dylan
trunk/libraries/network/koala/sources/koala/vhost.dylan
Log:
Job: koala
* clean-up api
* syntax clean-up
* replaced url handling with uri library
* make use of format-date()
* use updated regular-expression library
* regular-expression based responders
* url-map-definer
* output() in tag-definer
* separate DSPs in own directory
* regex-based request-line parsing
Modified: trunk/libraries/network/koala/config/koala-config.xml
==============================================================================
Binary files. No diff available.
Modified: trunk/libraries/network/koala/sources/dylan-basics/dylan-basics.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/dylan-basics/dylan-basics.dylan (original)
+++ trunk/libraries/network/koala/sources/dylan-basics/dylan-basics.dylan Sun Feb 17 19:09:45 2008
@@ -262,48 +262,6 @@
-// This should replace 'split' in common-extensions.
-define open generic split
- (string :: <string>,
- #key separator :: false-or(<string>),
- start: bpos :: <integer>,
- end: epos :: <integer>,
- trim? :: <boolean>,
- max :: false-or(<integer>),
- allow-empty-strings? :: <boolean>)
- => (strings :: <sequence>);
-
-define method split
- (string :: <byte-string>,
- #key separator :: false-or(<byte-string>),
- start :: <integer> = 0,
- end: _end :: <integer> = size(string),
- trim? :: <boolean> = #t,
- max: max-splits :: false-or(<integer>),
- allow-empty-strings? :: <boolean>)
- => (strings :: <stretchy-object-vector>)
- local method separator? (pos :: <integer>)
- block (return)
- for (i :: <integer> from pos, c in separator)
- if (i >= _end | string[i] ~== c)
- return(#f);
- end;
- end;
- #t
- end
- end,
- method is-white? (pos :: <integer>)
- whitespace?(string[pos])
- end;
- splitf(string,
- if (separator) separator? else is-white? end,
- if (separator) size(separator) else 1 end,
- start: start,
- end: _end,
- trim?: trim?,
- max: max-splits,
- allow-empty-strings?: allow-empty-strings?)
-end method split;
define method splitf
(string :: <byte-string>, separator? :: <function>, separator-size :: <integer>,
Modified: trunk/libraries/network/koala/sources/dylan-basics/library.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/dylan-basics/library.dylan (original)
+++ trunk/libraries/network/koala/sources/dylan-basics/library.dylan Sun Feb 17 19:09:45 2008
@@ -27,7 +27,6 @@
// --cgay
float-to-formatted-string,
join,
- split,
remove-keys, // For removing keywords from #rest arglists.
raise,
ignore-errors,
Modified: trunk/libraries/network/koala/sources/koala/config.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/config.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/config.dylan Sun Feb 17 19:09:45 2008
@@ -278,19 +278,36 @@
define method process-config-element
(node :: xml$<element>, name == #"document-root")
bind (loc = get-attr(node, #"location"))
- if(loc)
+ if (loc)
let vhost = active-vhost();
document-root(vhost)
:= merge-locators(as(<directory-locator>, loc), *server-root*);
log-info("VHost '%s': document root = %s.",
vhost-name(vhost), document-root(vhost));
else
- warn("Invalid <DOCUMENT-ROOT> spec. "
- "The 'location' attribute must be specified.");
- end;
+ warn("Invalid <DOCUMENT-ROOT> spec."
+ "The 'location' attribute must be specified.");
+ end if;
+ end;
+end;
+
+define method process-config-element
+ (node :: xml$<element>, name == #"dsp-root")
+ bind (loc = get-attr(node, #"location"))
+ if (loc)
+ let vhost = active-vhost();
+ vhost.dsp-root := merge-locators(as(<directory-locator>, loc),
+ *server-root*);
+ log-info("VHost '%s': document root = %s.",
+ vhost-name(vhost), document-root(vhost));
+ else
+ warn("Invalid <DSP-ROOT> spec."
+ "The 'location' attribute must be specified.");
+ end if;
end;
end;
+
define method process-config-element
(node :: xml$<element>, name == #"log")
let type = get-attr(node, #"type");
Modified: trunk/libraries/network/koala/sources/koala/dsp-main.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/dsp-main.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/dsp-main.dylan Sun Feb 17 19:09:45 2008
@@ -17,7 +17,7 @@
//// Initialization
begin
- register-auto-responder("dsp", auto-register-dylan-server-page);
+// register-auto-responder("dsp", auto-register-dylan-server-page);
when (*debugging-dsp*)
test-dsp();
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 Sun Feb 17 19:09:45 2008
@@ -164,21 +164,42 @@
end;
end;
+
+define generic root-directory
+ (page :: <object>)
+ => (root :: <directory-locator>);
+
+define method root-directory
+ (page :: <file-page-mixin>)
+ => (root :: <directory-locator>)
+ *virtual-host*.document-root;
+end;
+
+define method root-directory
+ (page :: <dylan-server-page>)
+ => (root :: <directory-locator>)
+ *virtual-host*.dsp-root;
+end;
+
+
define generic source-location
- (x :: <object>) => (location :: false-or(<locator>));
+ (x :: <object>)
+ => (location :: false-or(<locator>));
define method source-location
- (page :: <page>) => (location :: false-or(<locator>))
+ (page :: <page>)
+ => (location :: false-or(<locator>))
#f
end;
define method source-location
- (page :: <file-page-mixin>) => (location :: false-or(<locator>))
+ (page :: type-union(<file-page-mixin>, <dylan-server-page>))
+ => (location :: false-or(<locator>))
let loc :: <locator> = page.page-source;
if (locator-relative?(loc))
- let newloc = simplify-locator(merge-locators(loc, document-root(*virtual-host*)));
+ let newloc = simplify-locator(merge-locators(loc, root-directory(page)));
log-debug("source-location: newloc = %s", as(<string>, newloc));
- if (locator-below-document-root?(newloc))
+ if (locator-below-root?(newloc, root-directory(page)))
newloc
else
log-debug("Attempt to access a document outside the document root: %s",
@@ -191,7 +212,8 @@
end;
define method page-directory
- (page :: <file-page-mixin>) => (locator :: <directory-locator>)
+ (page :: type-union(<file-page-mixin>, <dylan-server-page>))
+ => (locator :: <directory-locator>)
locator-directory(source-location(page))
end;
@@ -698,7 +720,10 @@
end }
=> { define tag-aux #f ?tag ?taglib-spec
(?page, _do-body) (?tag-parameters)
- ?body; // semicolon is needed even when ?body ends in semicolon.
+ begin
+ let ?=output = curry(format, current-response().output-stream);
+ ?body; // semicolon is needed even when ?body ends in semicolon.
+ end;
_do-body(); // process the tag body
end
}
@@ -708,7 +733,10 @@
end }
=> { define tag-aux #t ?tag ?taglib-spec
(?page, ?do-body) (?tag-parameters)
- ?body
+ begin
+ let ?=output = curry(format, current-response().output-stream);
+ ?body;
+ end;
end
}
@@ -918,6 +946,7 @@
as(<string>, page.source-location));
end;
let source = document-location(url, context: page-directory(page));
+ log-debug("source: %s", source);
let contents = source & file-contents(source);
if (contents)
let subtemplate = make(<dsp-template>,
Modified: trunk/libraries/network/koala/sources/koala/koala-unix.lid
==============================================================================
--- trunk/libraries/network/koala/sources/koala/koala-unix.lid (original)
+++ trunk/libraries/network/koala/sources/koala/koala-unix.lid Sun Feb 17 19:09:45 2008
@@ -21,5 +21,6 @@
xml-rpc-server
config
responders
+ modules
koala-main
dsp-main
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 Sun Feb 17 19:09:45 2008
@@ -24,5 +24,6 @@
xml-rpc-server
config
responders
+ modules
koala-main
dsp-main
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 Sun Feb 17 19:09:45 2008
@@ -27,6 +27,8 @@
use base64;
use memory-manager;
use command-line-parser;
+ use uri;
+ use regular-expressions;
export koala;
export koala-extender;
@@ -65,7 +67,6 @@
wrapping-inc!,
file-contents,
pset, // multiple-value-setq
- path-element-equal?,
parent-directory,
date-to-stream,
kludge-read-into!, // work around bug in read-into! in FD 2.0
@@ -151,7 +152,9 @@
ensure-server, // Get (or create) the active HTTP server object.
start-server,
stop-server,
- register-url,
+ <responder>,
+ responder-map,
+ add-responder,
remove-responder,
<request>,
*request*, // Holds the active request, per thread.
@@ -162,6 +165,7 @@
request-method, // Returns #"get", #"post", etc
request-host,
responder-definer,
+ url-map-definer,
// Form/query values. (Is there a good name that covers both of these?)
get-query-value, // Get a query value that was passed in a URL or a form
@@ -181,8 +185,11 @@
<virtual-host>,
*virtual-host*,
document-root,
+ dsp-root,
vhost-name,
- locator-below-document-root?;
+ locator-below-document-root?,
+ locator-below-dsp-root?,
+ locator-below-root?;
// Responses
create
@@ -265,7 +272,7 @@
internal-server-error,
bad-request,
request-url,
- request-url-tail,
+ request-tail-url,
register-auto-responder;
// Debugging
@@ -305,53 +312,6 @@
create parse-header-value;
end;
-define module httpi // http internals
- use dylan;
- use threads; // from dylan lib
- use common-extensions,
- rename: { split => string-split },
- exclude: { format-to-string };
- use dylan-basics;
- use simple-random;
- use utilities,
- rename: { log-copious => %log-copious,
- log-verbose => %log-verbose,
- log-debug => %log-debug,
- log-info => %log-info,
- log-warning => %log-warning,
- log-error => %log-error };
- use koala;
- use koala-extender;
- use memory-manager;
- use locators,
- rename: { <http-server> => <http-server-url>,
- <ftp-server> => <ftp-server-url>,
- <file-server> => <file-server-url> };
- use dylan-extensions,
- import: { element-no-bounds-check,
- element-no-bounds-check-setter,
- element-range-check,
- element-range-error,
- // make-symbol,
- // case-insensitive-equal,
- // case-insensitive-string-hash
- };
- use format;
- use standard-io;
- use streams;
- use sockets,
- rename: { start-server => start-socket-server };
- use date; // from system lib
- use file-system; // from system lib
- use operating-system; // from system lib
- //use ssl-sockets;
- use xml-parser,
- prefix: "xml$";
- use xml-rpc-common;
- use base64;
- use command-line-parser;
-end module httpi;
-
define module dsp
use dylan;
use common-extensions,
@@ -468,3 +428,54 @@
*/
end module dsp;
+define module httpi // http internals
+ use dylan;
+ use threads; // from dylan lib
+ use common-extensions,
+ rename: { split => string-split },
+ exclude: { format-to-string };
+ use dylan-basics;
+ use simple-random;
+ use utilities,
+ rename: { log-copious => %log-copious,
+ log-verbose => %log-verbose,
+ log-debug => %log-debug,
+ log-info => %log-info,
+ log-warning => %log-warning,
+ log-error => %log-error };
+ use koala;
+ use koala-extender;
+ use memory-manager;
+ use locators,
+ rename: { <http-server> => <http-server-url>,
+ <ftp-server> => <ftp-server-url>,
+ <file-server> => <file-server-url> };
+ use dylan-extensions,
+ import: { element-no-bounds-check,
+ element-no-bounds-check-setter,
+ element-range-check,
+ element-range-error,
+ // make-symbol,
+ // case-insensitive-equal,
+ // case-insensitive-string-hash
+ };
+ use format;
+ use standard-io;
+ use streams;
+ use sockets,
+ rename: { start-server => start-socket-server };
+ use date; // from system lib
+ use file-system; // from system lib
+ use operating-system; // from system lib
+ //use ssl-sockets;
+ use xml-parser,
+ prefix: "xml$";
+ use xml-rpc-common;
+ use base64;
+ use command-line-parser;
+ use uri;
+ use regular-expressions;
+
+ use dsp;
+end module httpi;
+
Modified: trunk/libraries/network/koala/sources/koala/library.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/library.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/library.dylan Sun Feb 17 19:09:45 2008
@@ -27,6 +27,7 @@
use base64;
use memory-manager;
use command-line-parser;
+ use regular-expressions;
export koala;
export koala-extender;
@@ -66,7 +67,6 @@
wrapping-inc!,
file-contents,
pset, // multiple-value-setq
- path-element-equal?,
parent-directory,
date-to-stream,
kludge-read-into!, // work around bug in read-into! in FD 2.0
@@ -153,6 +153,9 @@
start-server,
stop-server,
register-url,
+ <responder>,
+ responder-map,
+ add-responder,
remove-responder,
<request>,
*request*, // Holds the active request, per thread.
@@ -353,6 +356,7 @@
import: { LoadLibrary, FreeLibrary };
use base64;
use command-line-parser;
+ use regular-expressions;
end module httpi;
define module dsp
Modified: trunk/libraries/network/koala/sources/koala/log.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/log.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/log.dylan Sun Feb 17 19:09:45 2008
@@ -181,35 +181,12 @@
end;
end;
-define method as-common-logfile-date (date :: <date>) => (common-logfile-date :: <string>)
- let $month-names
- = #["Jan", "Feb", "Mar", "Apr", "May", "Jun",
- "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"];
+define method as-common-logfile-date
+ (date :: <date>)
+ => (common-logfile-date :: <string>)
//Common Logfile Format Date: "28/Mar/2004:04:47:19 +0200"
//http://www.w3.org/Daemon/User/Config/Logging.html
- let (iyear, imonth, iday, ihours, iminutes, iseconds, day-of-week, time-zone-offset)
- = decode-date(date);
- local method wrap0 (int :: <integer>) => (string :: <string>)
- if (int < 10)
- concatenate("0", integer-to-string(int));
- else
- integer-to-string(int);
- end if;
- end;
-
- let day = wrap0(iday);
- let month = $month-names[imonth - 1];
- let year = integer-to-string(iyear);
- let hours = wrap0(ihours);
- let minutes = wrap0(iminutes);
- let seconds = wrap0(iseconds);
- let tzprefix = iff(negative?(time-zone-offset), "-", "+");
- let tzoff :: <integer> = abs(time-zone-offset);
- concatenate(day, "/", month, "/", year, ":", hours, ":", minutes,
- ":", seconds, " ",
- tzprefix,
- wrap0(floor/(tzoff, 60)),
- wrap0(modulo(tzoff, 60)))
+ format-date("%d/%b/%Y:%T %z", date);
end method as-common-logfile-date;
Added: trunk/libraries/network/koala/sources/koala/modules.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/koala/sources/koala/modules.dylan Sun Feb 17 19:09:45 2008
@@ -0,0 +1,43 @@
+module: httpi
+
+/// Modules
+
+define constant $module-map :: <table> = make(<string-table>);
+define constant $module-directory :: <string> = "modules";
+
+// Modules are loaded from <server-root>/modules.
+//
+define function module-pathname
+ (module-name :: <string>)
+ => (path :: <string>)
+ let module = as(<file-locator>,
+ format-to-string("%s/%s", $module-directory, module-name));
+ as(<string>, merge-locators(module, *server-root*))
+end function module-pathname;
+
+define function load-module
+ (module-name :: <string>)
+ let path = module-pathname(module-name);
+ log-info("Loading module '%s' from %s...", module-name, path);
+ // Note that the linux definition of load-library does nothing right now.
+ // -cgay 2004.05.06
+ let handle = load-library(path);
+ $module-map[module-name] := handle;
+end function load-module;
+
+define function unload-module
+ (module-name :: <string>)
+ /*
+ * unload-library isn't implemented yet in the operating-system module,
+ * and since there's no real need for this method I'm commenting it out
+ * for now. -cgay 2004.05.06
+ let handle = element($module-map, module-name, default: #f);
+ if (handle)
+ log-info("Unloading module %s...", module-name);
+ FreeLibrary(handle);
+ else
+ log-info("Couldn't unload module '%s'. Module not found.", module-name);
+ end;
+ */
+ log-warning("Unloading modules is not yet implemented.");
+end function unload-module;
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 Sun Feb 17 19:09:45 2008
@@ -6,10 +6,191 @@
License: Functional Objects Library Public License Version 1.0
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
+
+define class <responder> (<object>)
+ slot responder-map :: <table> = make(<table>),
+ init-keyword: map:;
+end;
+
+define open generic add-responder
+ (url :: <object>, responder :: <responder>, #key replace?)
+ => ();
+
+define method add-responder
+ (url :: <string>, responder :: <responder>, #key replace?)
+ => ();
+ add-responder(parse-url(url), responder, replace?: replace?);
+end;
+
+define method add-responder
+ (url :: <url>, responder :: <responder>, #key replace?)
+ => ();
+ local method responder-registration ()
+ if (empty?(url.uri-path))
+ error(make(<koala-api-error>,
+ format-string: "You can't add a responder with an empty URL: %s",
+ format-arguments: list(url)));
+ else
+ add-object(*server*.url-map, url.uri-path, responder, replace?: replace?);
+ log-info("responder on %s registered", url);
+ end if;
+ end;
+ if (*server-running?*)
+ responder-registration();
+ else
+ register-init-function(responder-registration);
+ end;
+end method add-responder;
+
+define open generic find-responder
+ (url :: <object>)
+ => (responder :: false-or(<responder>),
+ rest-path :: false-or(<sequence>));
+
+define method find-responder
+ (url :: <string>)
+ => (responder :: false-or(<responder>),
+ rest-path :: false-or(<sequence>));
+ find-responder(parse-url(url));
+end method find-responder;
+
+define method find-responder
+ (url :: <url>)
+ => (responder :: false-or(<responder>),
+ rest-path :: false-or(<sequence>));
+ find-object(*server*.url-map, url.uri-path);
+end method find-responder;
+
+
+define open generic remove-responder (object :: <object>);
+
+define method remove-responder (url :: <string>)
+ remove-responder(parse-url(url));
+end;
+
+define method remove-responder (url :: <url>)
+ remove-object(*server*.url-map, url.uri-path);
+end;
+
+
+define macro url-map-definer
+ { define url-map
+ ?urls
+ end }
+ => { ?urls }
+
+ urls:
+ { } => { }
+ { ?url ; ... } => { ?url ; ... }
+
+ url:
+ { url ?location:expression , ?definitions }
+ => { begin
+ let responder = make(<responder>);
+ ?definitions ;
+ ?location ;
+ end }
+ { url ( ?locations ) , ?definitions }
+ => { begin
+ let responder = make(<responder>);
+ ?definitions ;
+ ?locations ;
+ end }
+
+ locations:
+ { } => { }
+ { ?location , ... } => { ?location ; ... }
+
+ location:
+ { ?uri:expression } => { add-responder( ?uri , responder) }
+
+ definitions:
+ { } => { }
+ { ?definition , ... } => { ?definition ; ... }
+
+ definition:
+ { action ( ?request-methods ) ( ?regex ) => ?action:name }
+ => { begin
+ let regex = compile-regex(?regex);
+ let actions = list(?action);
+ ?request-methods
+ end }
+ { action ?request-method:name ( ?regex ) => ?action:name }
+ => { begin
+ let regex = compile-regex(?regex);
+ let actions = list(?action);
+ ?request-method
+ end }
+ { action ( ?request-methods ) ( ?regex ) => ( ?action-sequence:* ) }
+ => { begin
+ let regex = compile-regex(?regex);
+ let actions = list(?action-sequence);
+ ?request-methods
+ end }
+ { action ?request-method:name ( ?regex ) => ( ?action-sequence:* ) }
+ => { begin
+ let regex = compile-regex(?regex);
+ let actions = list(?action-sequence);
+ ?request-method
+ end }
+
+ request-methods:
+ { } => { }
+ { ?request-method , ... } => { ?request-method ; ... }
+
+ request-method:
+ { ?:name }
+ => { begin
+ let map = element(responder.responder-map,
+ ?#"name",
+ default: #f);
+ unless (map)
+ map := make(<table>);
+ responder.responder-map[?#"name"] := map;
+ end unless;
+ map[regex] := actions
+ end }
+
+ regex:
+ { } => { "^$" }
+ { * } => { ".*" }
+ { ?pattern:expression } => { ?pattern }
+
+end macro url-map-definer;
+
+// define responder test ("/test" /* , secure?: #t */ )
+// format(output-stream(response), "<html><body>test</body></html>");
+// end;
+define macro responder-definer
+ { define responder ?:name (?url:expression)
+ ?:body
+ end
+ }
+ => { define method ?name () ?body end;
+ register-url(?url, ?name)
+ }
+
+ { define directory responder ?:name (?url:expression)
+ ?:body
+ end
+ }
+ => { define method ?name () ?body end;
+ register-url(?url, ?name, prefix?: #t)
+ }
+end;
+
+/*
+define (get, post) responder foo-responder ("/foo", "/bar")
+ ("^(?P<name>\\w+)/?$")
+ (#key name)
+ ...
+end;
+*/
+
/*
// General server statistics
//
-define responder general-stats-responder ("/koala/stats")
+define responder general-stats-responder ("/koala/stats")
let stream = current-response().output-stream;
let server = current-request().request-server;
format(stream, "<html><body>");
Modified: trunk/libraries/network/koala/sources/koala/response.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/response.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/response.dylan Sun Feb 17 19:09:45 2008
@@ -159,7 +159,7 @@
// Log in Common Logfile Format
// (http://www.w3.org/Daemon/User/Config/Logging.html)
let request = concatenate(as-uppercase(as(<string>, request-method(req))), " ",
- request-url(req), " ",
+ build-uri(request-url(req)), " ",
as-uppercase(as(<string>, request-version(req))));
let date = as-common-logfile-date(current-date());
let remoteaddr = host-address(remote-host(request-socket(req)));
@@ -190,6 +190,7 @@
// Send the body (or what there is of it so far).
write(stream, contents);
end unless;
+ log-debug("Send response.");
end;
// Exported
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 Sun Feb 17 19:09:45 2008
@@ -6,12 +6,10 @@
License: Functional Objects Library Public License Version 1.0
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-
define constant $http-version = "HTTP/1.1";
define constant $server-name = "Koala";
define constant $server-version = "0.4";
-
// This may be set true by config file loading code, in which case
// start-server will be a no-op.
define variable *abort-startup?* :: <boolean> = #f;
@@ -498,7 +496,7 @@
define class <request> (<basic-request>)
slot request-method :: <symbol> = #"unknown";
slot request-version :: <symbol> = #"unknown";
- slot request-url :: <string> = "";
+ slot request-url :: false-or(<url>) = #f;
// See http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.2
slot request-host :: false-or(<string>) = #f;
@@ -513,8 +511,6 @@
// Cache, mapping keyword (requested by user) -> parsed data
constant slot request-header-values :: <object-table> = make(<object-table>);
- slot request-query-string :: <string> = "";
-
// Query values from either the URL or the body of the POST, if Content-Type
// is application/x-www-form-urlencoded.
constant slot request-query-values :: <string-table> = make(<string-table>);
@@ -524,11 +520,10 @@
// The body content of the request. Only present for POST?
slot request-content :: <string> = "";
- slot request-responder :: false-or(<function>) = #f;
+ slot request-responder :: false-or(<responder>) = #f;
- // For directory responders, this contains the part of the URL after
- // the matched directory prefix and before the ? (if any).
- slot request-url-tail :: <string> = "";
+ // contains the relative URL after the matched responder
+ slot request-tail-url :: false-or(<url>) = #f;
end class <request>;
@@ -542,11 +537,6 @@
define thread variable *request* :: false-or(<request>) = #f;
define thread variable *response* :: false-or(<response>) = #f;
-// Holds the map of query keys/vals in the "?x=1&y=2" part of the URL (for GET method)
-// or form keys/vals for the POST method.
-define thread variable *request-query-values* :: <string-table>
- = make(<string-table>);
-
define inline function current-request () => (request :: <request>) *request* end;
define inline function current-response () => (response :: <response>) *response* end;
@@ -583,8 +573,7 @@
block ()
block ()
read-request(request);
- dynamic-bind (*request-query-values* = request.request-query-values,
- *virtual-host* = virtual-host(request))
+ dynamic-bind (*virtual-host* = virtual-host(request))
log-debug("Virtual host for request is '%s'",
vhost-name(*virtual-host*));
invoke-handler(request);
@@ -621,76 +610,57 @@
pset (buffer, len) read-request-line(socket) end;
end;
log-info("%s", substring(buffer, 0, len));
- read-request-first-line(request, buffer, len);
+ read-request-first-line(request, buffer);
unless (request.request-version == #"http/0.9")
request.request-headers
:= read-message-headers(socket,
buffer: buffer,
start: len,
headers: request.request-headers);
- end;
+ end unless;
process-incoming-headers(request);
- if (request.request-method == #"post" |
- request.request-method == #"put")
- read-request-content(request);
- end;
-end read-request;
+ select (request.request-method by \==)
+ #"post", #"put" => read-request-content(request);
+ otherwise => #f;
+ end select;
+end method read-request;
// Read first line of the HTTP request. RFC 2068 Section 5.1
-//
-// Request-Line = Method SP Request-URI SP HTTP-Version CRLF
-//
-// ---TODO: this code would be a lot clearer if it used regular expressions.
-//
+
define function read-request-first-line
- (request :: <request>, buffer :: <string>, eol :: <integer>)
+ (request :: <request>, buffer :: <string>)
=> ()
- let method-end = whitespace-position(buffer, 0, eol) | eol;
- if (zero?(method-end))
- invalid-request-line-error();
+ let (match, http-method, url, http-version) =
+ regex-search-strings("^([!#$%&'\\*\\+-\\./0-9A-Z^_`a-z\\|~]+) "
+ "(\\S+) "
+ "(HTTP/\\d+\\.\\d+)", buffer);
+ log-debug("%= %= %=", http-method, url, http-version);
+ if (match)
+ request.request-method := as(<symbol>, http-method);
+ let url = parse-url(url);
+ // See http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.2
+ // Absolute URLs in the request line take precedence over Host header.
+ if (absolute?(url))
+ request.request-host := url.uri-host;
+ end if;
+ request.request-url := url;
+ let (responder, tail) = find-responder(request.request-url);
+ log-debug("Responder: %=", responder);
+ request.request-responder := responder;
+ if (tail)
+ request.request-tail-url := make(<url>, path: as(<deque>, tail));
+ log-debug("Setting request-tail-url to %s", request.request-tail-url);
+ end if;
+ for (value keyed-by key in url.uri-query)
+ request.request-query-values[key] := value;
+ end for;
+ request.request-version := extract-request-version(http-version);
else
- request.request-method
- := as(<symbol>, copy-sequence(buffer, start: 0, end: method-end));
- let bpos = skip-whitespace(buffer, method-end, eol);
- let epos = whitespace-position(buffer, bpos, eol) | eol;
- when (epos > bpos)
- let qpos = char-position('?', buffer, bpos, epos);
-
- if (looking-at?("http://", buffer, bpos, qpos | epos))
- // See http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.2
- // Absolute URLs in the request line take precedence over Host header.
- bpos := bpos + 7;
- let host-end = char-position('/', buffer, bpos, qpos | epos);
- request.request-host := substring(buffer, bpos, host-end | epos);
- bpos := host-end;
- end if;
- if (epos > bpos)
- // Should this trim trailing whitespace???
- request.request-url := substring(buffer, bpos, qpos | epos);
- let (resp, prefix?, tail) = find-responder(request.request-url);
- // If there's a tail (i.e., we didn't match the entire url) and
- // this isn't a directory responder, then no responder was found.
- if (~tail | prefix?)
- request.request-responder := resp;
- end;
- if (tail)
- request.request-url-tail := join(tail, "/");
- log-debug("Setting request-url-tail to %=", request.request-url-tail);
- end;
- if (qpos)
- request.request-query-string := copy-sequence(buffer, start: qpos + 1, end: epos);
- log-debug("Request query string = %s", request.request-query-string);
- extract-query-values(buffer, qpos + 1, epos,
- request.request-query-values)
- end;
- let bpos = skip-whitespace(buffer, epos, eol);
- let vpos = whitespace-position(buffer, bpos, eol) | eol;
- request.request-version := extract-request-version(buffer, bpos, vpos);
- end if;
- end;
- end;
-end;
+ invalid-request-line-error();
+ end if;
+end function read-request-first-line;
+
define function read-request-content
(request :: <request>)
@@ -717,12 +687,13 @@
let content-type-header = get-header(request, "content-type");
as(<symbol>,
if (content-type-header)
- first(split(content-type-header, separator: ";"))
+ first(split(content-type-header, ";"))
else
""
end if)
end;
+
// Gary, in the trunk sources (1) below should now be fixed. (read was passing the
// wrong arguments to next-method).
// (2) should also be fixed. It used to cause "Dylan error: 35 is not of type {<class>: <sequence>}"
@@ -751,6 +722,7 @@
end;
end;
+
define open generic process-request-content
(content-type :: <symbol>,
request :: <request>,
@@ -768,19 +740,23 @@
end;
define method process-request-content
- (content-type == #"application/x-www-form-urlencoded", request :: <request>,
- buffer :: <byte-string>, content-length :: <integer>)
+ (content-type == #"application/x-www-form-urlencoded",
+ request :: <request>,
+ buffer :: <byte-string>,
+ content-length :: <integer>)
=> (content :: <string>)
- log-debug("Form query string = %=",
- copy-sequence(buffer, end: content-length));
- let content = decode-url(buffer, 0, content-length);
- // By the time we get here request-query-values has already been bound to a <string-table>
- // containing the URL query values. Now we augment it with any form values.
- extract-query-values(buffer, 0, content-length,
- request.request-query-values);
- request-content(request) := content
- // ---TODO: Deal with content types intelligently. For now this'll have to do.
-end;
+ let query = copy-sequence(buffer, end: content-length);
+ log-debug("Form query string = %=", query);
+ // By the time we get here request-query-values has already
+ // been bound to a <string-table> containing the URL query
+ // values. Now we augment it with any form values.
+ for (value keyed-by key in split-query(query))
+ request.request-query-values[key] := value;
+ end for;
+ request-content(request) := query;
+ // ---TODO: Deal with content types intelligently.
+ // For now this'll have to do.
+end method process-request-content;
define method process-request-content
(content-type :: one-of(#"text/xml", #"text/html", #"text/plain"),
@@ -791,12 +767,15 @@
request-content(request) := buffer
end;
+/* REWRITE
define method process-request-content
- (content-type == #"multipart/form-data", request :: <request>,
- buffer :: <byte-string>, content-length :: <integer>)
+ (content-type == #"multipart/form-data",
+ request :: <request>,
+ buffer :: <byte-string>,
+ content-length :: <integer>)
=> (content :: <string>)
- let header-content-type = split(get-header(request, "content-type"), separator: ";");
- let boundary = split(second(header-content-type), separator: "=");
+ let header-content-type = split(get-header(request, "content-type"), ";");
+ let boundary = split(second(header-content-type), "=");
if (element(boundary, 1, default: #f))
let boundary-value = second(boundary);
log-debug("boundary: %=", boundary-value);
@@ -807,7 +786,8 @@
log-error("%=", "content-type is missing the boundary parameter");
unsupported-media-type-error();
end if;
-end;
+end method process-request-content;
+*/
define function send-error-response (request :: <request>, c :: <condition>)
block ()
@@ -817,6 +797,7 @@
end;
end;
+
define method send-error-response-internal (request :: <request>, err :: <error>)
let headers = http-error-headers(err) | make(<header-table>);
let response = make(<response>, request: request, headers: headers);
@@ -830,7 +811,8 @@
response.response-code := http-error-code(err);
response.response-message := one-liner;
send-response(response);
-end method;
+end method send-error-response-internal;
+
// Do whatever we need to do depending on the incoming headers for
// this request. e.g., handle "Connection: Keep-alive", store
@@ -864,70 +846,7 @@
end;
end;
-// API
-// Register a response function for a given URL. See find-responder.
-define method register-url
- (url :: <string>, target :: <function>, #key replace?, prefix?)
- => ()
- local method reg-url ()
- register-url-now(url, target, replace?: replace?, prefix?: prefix?);
- end;
- if (*server-running?*)
- reg-url();
- else
- register-init-function(reg-url);
- end;
-end method register-url;
-
-define method register-url-now
- (url :: <string>, target :: <function>, #key replace?, prefix?)
- let server :: <server> = *server*;
- let (bpos, epos) = trim-whitespace(url, 0, size(url));
- if (bpos = epos)
- error(make(<koala-api-error>,
- format-string: "You cannot register an empty URL: %=",
- format-arguments: list(substring(url, bpos, epos))));
- else
- add-object(server.url-map, url, pair(target, prefix?), replace?: replace?);
- end;
- log-info("URL %s%s registered", url, if (prefix?) "/*" else "" end);
-end method register-url-now;
-
-// Find a responder function, if any.
-define method find-responder
- (url :: <string>)
- => (responder :: false-or(<function>), #rest more)
- local method maybe-auto-register (url)
- when (*auto-register-pages?*)
- // could use safe-locator-from-url, but it's relatively expensive
- let len = size(url);
- let slash = char-position-from-end('/', url, 0, len);
- let dot = char-position-from-end('.', url, slash | 0, len);
- when (dot & dot < len - 1)
- let ext = substring(url, dot + 1, len);
- let reg-fun = element(*auto-register-map*, ext, default: #f);
- reg-fun & reg-fun(url)
- end
- end
- end;
- let url = decode-url(url, 0, size(url));
- let path = split(url, separator: "/");
- let trie = url-map(*server*);
- let (responder, rest) = find-object(trie, path);
- if (responder)
- let fun = head(responder);
- let prefix? = tail(responder);
- values(fun, prefix?, rest)
- else
- maybe-auto-register(url)
- end
-end find-responder;
-
-define open generic remove-responder (object :: <object>);
-
-define method remove-responder (url :: <string>)
- remove-object(*server*.url-map, url)
-end;
+/* REMOVE
// Register a function that will attempt to register a responder for a URL
// if the URL matches the file extension. The function should normally call
@@ -943,51 +862,73 @@
*auto-register-map*[file-extension] := f;
end;
-// define responder test ("/test" /* , secure?: #t */ )
-// format(output-stream(response), "<html><body>test</body></html>");
-// end;
-define macro responder-definer
- { define responder ?:name (?url:expression)
- ?:body
- end
- }
- => { define method ?name () ?body end;
- register-url(?url, ?name)
- }
-
- { define directory responder ?:name (?url:expression)
- ?:body
- end
- }
- => { define method ?name () ?body end;
- register-url(?url, ?name, prefix?: #t)
- }
-end;
+*/
+
+
// Invoke the appropriate handler for the given request URL and method.
// Have to buffer up the entire response since the web app needs a chance to
// set headers, etc. And if the web app signals an error we need to catch it
// and generate the appropriate error response.
-define method invoke-handler
- (request :: <request>) => ()
+define method invoke-handler (request :: <request>) => ()
let headers = make(<header-table>);
let response = make(<response>,
request: request,
headers: headers);
- if(request.request-keep-alive?)
+ if (request.request-keep-alive?)
add-header(response, "Connection", "Keep-Alive");
end if;
dynamic-bind (*response* = response)
if (request.request-responder)
- log-debug("%s handler found", request-url(request));
- request.request-responder();
+ let url = request.request-url;
+ log-debug("Responder found for %s", url);
+ let map = request.request-responder.responder-map;
+ let responders = element(map, request.request-method, default: #f);
+ // find the appropriate action sequence
+ let (action-sequence, match) = if (responders)
+ block (return)
+ for (action-sequence keyed-by regex in responders)
+ let tail = build-path(request.request-tail-url);
+ log-debug("? %= <=> %=", regex.regex-pattern, tail);
+ let match = regex-search(regex, tail);
+ if (match)
+ return(action-sequence, match)
+ end if;
+ end for;
+ end block;
+ end if;
+ log-debug("Action sequence: %=", action-sequence);
+ log-debug("Responder match: %=", match);
+ if (action-sequence)
+ //
+ let arguments = make(<stretchy-vector>);
+ for (group keyed-by name in match.groups-by-name)
+ add!(arguments, as(<symbol>, name));
+ add!(arguments, group.group-text);
+ end for;
+ do(method (action)
+ select (action by instance?)
+ <function> => apply(action, arguments);
+ <dylan-server-page> =>
+ respond-to(request.request-method, action);
+ otherwise =>
+ log-warning("Unknown action %= in action sequence.", action);
+ end select
+ end, action-sequence);
+ else
+ resource-not-found-error(url: url);
+ end if;
else
+ log-debug("Maybe serve static file");
// generates 404 if not found
maybe-serve-static-file();
- end;
+ end if;
end;
send-response(response);
-end invoke-handler;
+end method invoke-handler;
+
+//define class <action-sequence-error> (<error>)
+//end;
// Read a line of input from the stream, dealing with CRLF correctly.
//
@@ -1024,19 +965,15 @@
len == 1 & buffer[0] == $cr
end;
-define function extract-request-version (buffer :: <string>,
- bpos :: <integer>,
- epos :: <integer>)
- if (bpos == epos)
- #"HTTP/0.9"
- elseif (string-match("HTTP/1.0", buffer, bpos, epos))
- #"HTTP/1.0"
- elseif (string-match("HTTP/1.1", buffer, bpos, epos))
- #"HTTP/1.1"
- else
- unsupported-http-version-error()
- end;
-end extract-request-version;
+define function extract-request-version
+ (buffer :: <string>)
+ => (version :: <symbol>)
+ let version = as(<symbol>, buffer);
+ select (version)
+ #"HTTP/0.9", #"HTTP/1.0", #"HTTP/1.1" => version;
+ otherwise => unsupported-http-version-error();
+ end select;
+end;
define class <http-file> (<object>)
slot http-file-filename :: <string>,
@@ -1047,20 +984,21 @@
required-init-keyword: mime-type:;
end;
+/* REWRITE
define method extract-form-data
(buffer :: <string>, boundary :: <string>, request :: <request>)
// strip everything after end-boundary
- let buffer = first(split(buffer, separator: concatenate("--", boundary, "--")));
- let parts = split(buffer, separator: concatenate("--", boundary));
+ let buffer = first(split(buffer, concatenate("--", boundary, "--")));
+ let parts = split(buffer, concatenate("--", boundary));
for (part in parts)
- let part = split(part, separator: "\r\n\r\n");
- let header-entries = split(first(part), separator: "\r\n");
+ let part = split(part, "\r\n\r\n");
+ let header-entries = split(first(part), "\r\n");
let disposition = #f;
let name = #f;
let type = #f;
let filename = #f;
for (header-entry in header-entries)
- let header-entry-parts = split(header-entry, separator: ";");
+ let header-entry-parts = split(header-entry, ";");
for (header-entry-part in header-entry-parts)
let eq-pos = char-position('=', header-entry-part, 0, size(header-entry-part));
let p-pos = char-position(':', header-entry-part, 0, size(header-entry-part));
@@ -1093,121 +1031,10 @@
log-debug("multipart/form-data for %=: %=, %=, %=", name, disposition, type, filename);
end for;
end method extract-form-data;
+*/
-// Turn a string like "foo=8&bar=&baz=zzz" into a <string-table> with the "obvious" keys/vals.
-// Note that in the above example string "bar" maps to "", not #f.
-//---TODO: Find out if the query keys are case-sensitive in the HTTP spec and make sure this
-// does the right thing.
-define method extract-query-values
- (buffer :: <string>, bpos :: <integer>, epos :: <integer>, queries :: <string-table>)
- => (queries :: <string-table>)
- local method extract-key/val (beg :: <integer>, fin :: <integer>)
- let eq-pos = char-position('=', buffer, beg, fin);
- if (eq-pos & (eq-pos > beg))
- let key = decode-url(buffer, beg, eq-pos);
- let val = decode-url(buffer, eq-pos + 1, fin);
- values(key, val)
- else
- values(decode-url(buffer, beg, fin), #t)
- end if;
- end;
- local method insert-key/val (key :: <string>, val :: type-union(<string>, <boolean>))
- let hashtable-value = element(queries, key, default: #f);
- if (hashtable-value)
- //for multiple selection option boxes, arguments are passed this way:
- // "foo=2&foo=3&foo=4", that's why we first do a lookup in the hash-table
- // and generate a <stretchy-vector> on the fly -- hannes, 17.11.2007
- if (instance?(hashtable-value, <string>))
- let vec = make(<stretchy-vector>);
- add!(vec, hashtable-value);
- add!(vec, val);
- queries[key] := vec;
- else
- add!(hashtable-value, val);
- end;
- else
- queries[key] := val;
- end;
- end;
- iterate loop (start :: <integer> = bpos)
- when (start < epos)
- let _end = char-position('&', buffer, start, epos) | epos;
- let (key, val) = extract-key/val(start, _end);
- when (key & val)
- insert-key/val(key, val);
- end;
- loop(_end + 1);
- end;
- end;
- queries
-end extract-query-values;
-
-define method get-query-value
- (key :: <string>, #key as: as-type :: false-or(<type>)) => (val :: <object>)
- let value = element(*request-query-values*, key, default: #f);
- iff (as-type & value,
- as(as-type, value),
- value)
-end;
-
-define method count-query-values
- () => (n :: <integer>)
- size(*request-query-values*)
-end;
-
-define method do-query-values
- (f :: <function>)
- for (val keyed-by key in *request-query-values*)
- f(key, val);
- end;
-end;
-
-// Is there any need to maintain POSTed values separately from GET query values?
-// Don't think so, so this should be ok.
-define constant get-form-value :: <function> = get-query-value;
-define constant do-form-values :: <function> = do-query-values;
-define constant count-form-values :: <function> = count-query-values;
-
-
-/// Modules
-
-define constant $module-map :: <table> = make(<string-table>);
-define constant $module-directory :: <string> = "modules";
-
-// Modules are loaded from <server-root>/modules.
-//
-define function module-pathname
- (module-name :: <string>) => (path :: <string>)
- as(<string>,
- merge-locators(as(<file-locator>,
- format-to-string("%s/%s", $module-directory, module-name)),
- *server-root*))
-end;
-
-define function load-module
- (module-name :: <string>)
- let path = module-pathname(module-name);
- log-info("Loading module '%s' from %s...", module-name, path);
- // Note that the linux definition of load-library does nothing right now.
- // -cgay 2004.05.06
- let handle = load-library(path);
- $module-map[module-name] := handle;
-end;
-
-define function unload-module
- (module-name :: <string>)
- /*
- * unload-library isn't implemented yet in the operating-system module,
- * and since there's no real need for this method I'm commenting it out
- * for now. -cgay 2004.05.06
- let handle = element($module-map, module-name, default: #f);
- if (handle)
- log-info("Unloading module %s...", module-name);
- FreeLibrary(handle);
- else
- log-info("Couldn't unload module '%s'. Module not found.", module-name);
- end;
- */
- log-warning("Unloading modules is not yet implemented.");
+define inline function get-query-value
+ (key :: <string>)
+ => (value :: <object>)
+ element(*request*.request-query-values, key, default: #f);
end;
-
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 Sun Feb 17 19:09:45 2008
@@ -33,7 +33,7 @@
if (locator-name(loc) = "..")
loc := locator-directory(locator-directory(loc));
end;
- locator-below-document-root?(loc) & loc
+ locator-below-root?(loc, context) & loc
end if
end if
exception (ex :: <locator-error>)
@@ -45,7 +45,7 @@
define method maybe-serve-static-file ()
let request = current-request();
let response = current-response();
- let url :: <string> = request-url(request);
+ let url = build-uri(request.request-url);
let document :: false-or(<physical-locator>)
= static-file-locator-from-url(url);
log-debug("Requested document is %s", document);
@@ -134,20 +134,34 @@
end;
end;
-define method locator-below-document-root?
- (locator :: <physical-locator>) => (below? :: <boolean>)
- let relative = relative-locator(locator, document-root(*virtual-host*));
- locator-relative?(relative) // do they at least share a common ancestor?
- & begin
- let relative-parent = locator-directory(relative);
- ~relative-parent // is it a file directly in the root dir?
- | begin
- let relative-path = locator-path(relative-parent);
- empty?(relative-path) // again, is it directly in the root dir?
- | relative-path[0] ~= #"parent" // does it start with ".."?
- end
- end
-end;
+define method locator-below-document-root?
+ (locator :: <physical-locator>)
+ => (below? :: <boolean>)
+ locator-below-root?(locator, *virtual-host*.document-root)
+end;
+
+define method locator-below-dsp-root?
+ (locator :: <physical-locator>)
+ => (below? :: <boolean>)
+ locator-below-root?(locator, *virtual-host*.dsp-root)
+end;
+
+define method locator-below-root?
+ (locator :: <physical-locator>, root :: <directory-locator>)
+ => (below? :: <boolean>)
+ let relative = relative-locator(locator, root);
+ // do they at least share a common ancestor?
+ if (locator-relative?(relative))
+ let relative-parent = locator-directory(relative);
+ // is it a file directly in the root dir?
+ ~relative-parent | begin
+ let relative-path = locator-path(relative-parent);
+ // again, is it directly in the root dir?
+ empty?(relative-path) |
+ relative-path[0] ~= #"parent" // does it start with ".."?
+ end;
+ end if;
+end method locator-below-root?;
// Get MIME Type for file name
@@ -176,7 +190,9 @@
end;
end;
-define method etag (locator :: <locator>) => (etag :: <string>, weak? :: <boolean>)
+define method etag
+ (locator :: <locator>)
+ => (etag :: <string>, weak? :: <boolean>)
//generate an etag (use modification date and size)
// --TODO: algorithm should be changed (md5?), because a file can
//changes more than once per second without changing size.
Modified: trunk/libraries/network/koala/sources/koala/urls.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/urls.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/urls.dylan Sun Feb 17 19:09:45 2008
@@ -6,193 +6,18 @@
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-//define class <sealed-constructor> (<object>) end;
-define sealed domain make(subclass(<sealed-constructor>));
-define sealed domain initialize(<sealed-constructor>);
-
-define function make-locator (netloc :: false-or(<http-server-url>),
- dir :: <simple-object-vector>,
- name :: false-or(<string>),
- type :: false-or(<string>),
- query :: false-or(<string>),
- // note request url's don't have tags, it's a browser thang.
- tag :: false-or(<string>))
- let dir = make(<directory-url>, server: netloc, relative?: #f, path: dir);
- if (type | name | tag | query)
- make(<file-url>, directory: dir, base: name, extension: type,
- cgi-string: query, index: tag)
- else
- dir
- end;
-end make-locator;
-
-define function decode-url
- (str :: <byte-string>, bpos :: <integer>, epos :: <integer>)
- => (str :: <byte-string>)
- // Replace '+' with Space. See RFC 1866 (HTML) section 8.2.
- for (i from 0 below str.size)
- iff(str[i] == '+',
- str[i] := ' ');
- end;
- // Note: n accumulates how many chars are NOT needed in the copy.
- iterate count (pos :: <integer> = bpos, n :: <integer> = 0)
- let pos = char-position('%', str, pos, epos);
- if (pos)
- if (pos + 3 <= epos)
- count(pos + 3, n + 2)
- else
- invalid-url-encoding-error();
- end;
- elseif (n == 0)
- substring(str, bpos, epos)
- else // Ok, really have to copy...
- let nlen = epos - bpos - n;
- let nstr = make(<byte-string>, size: nlen);
- iterate copy (i :: <integer> = 0, pos :: <integer> = bpos)
- unless (pos == epos)
- let ch = str[pos];
- if (ch ~== '%')
- nstr[i] := ch;
- copy(i + 1, pos + 1);
- else
- let c1 = digit-weight(str[pos + 1]);
- let c2 = digit-weight(str[pos + 2]);
- if (c1 & c2)
- nstr[i] := as(<byte-character>, c1 * 16 + c2);
- copy(i + 1, pos + 3);
- else
- invalid-url-encoding-error();
- end;
- end;
- end unless;
- end iterate;
- nstr
- end if;
- end iterate;
-end decode-url;
-
-define function encode-url (url :: <byte-string>, #key reserved?)
- => (encoded-url :: <byte-string>);
- let reserved-chars = "$-_.+!*'(),";
- let encoded-url = "";
- for (char in url)
- if (((char >= 'a' & char <= 'z') |
- (char >= 'A' & char <= 'Z') |
- (char >= '0' & char <= '9')) |
- (member?(char, reserved-chars) &
- ~reserved?))
- encoded-url := add!(encoded-url, char);
- else
- encoded-url :=
- concatenate(encoded-url, "%",
- format-to-string("%X", as(<byte>, char)));
- end if;
- end for;
- encoded-url;
+define inline function current-url () => (url :: <url>);
+ *request*.request-url
end;
-define function parse-request-url (str, bpos, epos)
- => (url :: <url>) // <http-url>, but that's bogus.
- parse-url(str, bpos, epos)
- | invalid-url-error(url: substring(str, bpos, epos));
-end;
-
-define function parse-url (str, str-beg, str-end)
- => (url :: false-or(<url>))
- // Assumed to be either absolute URL (i.e. "scheme:...") or
- // absolute path (i.e. "/..."). Doesn't accept relative path.
- // For now, only accepts http: as scheme.
- if (str-beg == str-end)
- #f // This should probably treat "" the same as "/" (according to RFC 2616) --sigue
- elseif (str[str-beg] == '/')
- let (dir, name, type, query, tag) = parse-url-path(str, str-beg, str-end);
- dir & make-locator(#f, dir, name, type, query, tag);
- elseif (looking-at?("http://", str, str-beg, str-end))
- let net-beg = str-beg + 7;
- let net-end = char-position('/', str, net-beg, str-end) | str-end;
- let netloc = parse-http-server(str, net-beg, net-end);
- let (dir, name, type, query, tag) = if (net-end == str-end)
- parse-url-path("/", 0, 1)
- else
- parse-url-path(str, net-end, str-end)
- end;
- dir & netloc & make-locator(netloc, dir, name, type, query, tag);
- else
- //---TODO: here should distinguish between an unknown scheme and a relative path.
- #f
- end;
-end parse-url;
-
-define function current-url (#key escaped?)
- => (uri :: <string>);
- let request = current-request();
- let path = if (escaped?)
- encode-url(request.request-url, reserved?: #t)
- else
- current-request().request-url
- end if;
- let query-string = if (~empty?(request.request-query-string))
- concatenate("?", request.request-query-string)
- else
- ""
- end if;
- concatenate(path, query-string)
-end current-url;
-
-define function parse-http-server (str :: <byte-string>,
- net-beg :: <integer>,
- net-end :: <integer>)
- => (netloc :: false-or(<http-server-url>))
- let host-end = char-position(':', str, net-beg, net-end) | net-end;
- let host = decode-url(str, net-beg, host-end);
- let port = if (host-end == net-end)
- 80
- else
- //---TODO: should decode-url this as well, in theory...
- string->integer(str, host-end + 1, net-end)
- end;
- host & port & make(<http-server-url>, host: host, port: port);
-end parse-http-server;
+define open generic redirect-to (object :: <object>);
-//---TODO: should intern these, i.e. map the whole thing to its parsed version...
-
-// dir is #f if parse failed.
-define function parse-url-path
- (str, str-beg, str-end)
- => (dir :: false-or(<simple-object-vector>),
- name :: false-or(<string>),
- type :: false-or(<string>),
- query :: false-or(<string>))
- assert(str[str-beg] == '/');
- let path-end = char-position('?', str, str-beg, str-end) | str-end;
- let segs = make(<stretchy-vector>);
- iterate loop (beg = str-beg)
- let beg = beg + 1;
- let pos = char-position('/', str, beg, path-end);
- if (pos)
- let seg = decode-url(str, beg, pos);
- if (seg)
- add!(segs, seg);
- loop(pos);
- else
- values(#f, #f, #f, #f);
- end;
- else
- let segs = as(<simple-object-vector>, segs);
- let dot-pos = char-position-from-end('.', str, beg, path-end);
- let name = decode-url(str, str-beg, dot-pos | path-end);
- let type = dot-pos & decode-url(str, dot-pos + 1, path-end);
- let query = (path-end ~== str-end) & substring(str, path-end + 1, str-end);
- values(segs, name, type, query)
- end;
- end iterate;
-end parse-url-path;
-
-define open generic redirect-to (object :: <object>, #key);
-
-define method redirect-to (url :: <string>, #key #all-keys)
+define method redirect-to (url :: <string>)
let headers = current-response().response-headers;
add-header(headers, "Location", url);
see-other-redirect(headers: headers);
-end;
+end method redirect-to;
+define method redirect-to (url :: <url>)
+ redirect-to(build-uri(url));
+end;
Modified: trunk/libraries/network/koala/sources/koala/utils.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/utils.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/utils.dylan Sun Feb 17 19:09:45 2008
@@ -20,6 +20,7 @@
// Things that expire.
+
define class <expiring-mixin> (<object>)
constant slot duration :: <day/time-duration>
= encode-day/time-duration(0, 1, 0, 0, 0), // 1 hour
@@ -29,13 +30,13 @@
end;
define method expired?
- (thing :: <expiring-mixin>) => (expired? :: <boolean>)
- thing.mod-time == #f
- | begin
+ (thing :: <expiring-mixin>)
+ => (expired? :: <boolean>);
+ thing.mod-time == #f | begin
let now = current-date();
(now - thing.mod-time) < thing.duration
- end
-end expired?;
+ end;
+end method expired?;
@@ -85,18 +86,6 @@
-// Compare two locator-path elements.
-//---*** TODO: portability - This isn't portable.
-define method path-element-equal?
- (elem1 :: <object>, elem2 :: <object>) => (equal? :: <boolean>)
- elem1 = elem2
-end;
-
-define method path-element-equal?
- (elem1 :: <string>, elem2 :: <string>) => (equal? :: <boolean>)
- string-equal?(elem1, elem2)
-end;
-
define sideways method locator-path
(locator :: <file-locator>) => (path :: <sequence>)
locator-path(locator-directory(locator))
@@ -191,24 +180,26 @@
define class <string-trie> (<object>)
constant slot trie-children :: <string-table> = make(<string-table>);
slot trie-object :: <object>,
- required-init-keyword: #"object";
+ required-init-keyword: object:;
end;
define class <trie-error> (<format-string-condition>, <error>)
end;
define method add-object
- (trie :: <string-trie>, path :: <string>, object :: <object>,
+ (trie :: <string-trie>, path :: <sequence>, object :: <object>,
#key replace?)
- local method real-add (trie :: <string-trie>, rest-path :: <sequence>)
+ => ();
+ local method real-add (trie, rest-path)
if (rest-path.size = 0)
if (trie.trie-object = #f | replace?)
trie.trie-object := object;
else
- let fmt = format-to-string("Trie already contains an object for the "
- "given path (%=).", path);
- signal(make(<trie-error>, format-string: fmt))
- end;
+ signal(make(<trie-error>,
+ format-string: "Trie already contains an object for the "
+ "given path (%=).",
+ format-arguments: list(path)));
+ end if;
else
let first-path = rest-path[0];
let other-path = copy-sequence(rest-path, start: 1);
@@ -221,12 +212,13 @@
end;
real-add(child, other-path)
end;
- end;
- real-add(trie, split(path, separator: "/"))
+ end method real-add;
+ real-add(trie, path)
end method add-object;
-define method remove-object (trie :: <string-trie>, path :: <string>)
- let path = split(path, separator: "/");
+define method remove-object
+ (trie :: <string-trie>, path :: <sequence>)
+ => ();
let nodes = #[];
let node = reduce(method (a, b)
nodes := add!(nodes, a);
@@ -246,28 +238,31 @@
object;
end;
-// Find the object with the longest path, if any. 2nd return value is
-// the part of the path that came after where the object matched.
-//
+
+// Find the object with the longest path, if any.
+// 2nd return value is the part of the path that
+// came after where the object matched.
+
define method find-object
(trie :: <string-trie>, path :: <sequence>)
- local method fob (trie :: <string-trie>, path :: <list>, obj, rest)
+ => (object :: <object>, rest-path :: <sequence>);
+ local method real-find (trie, path, object, rest)
if (empty?(path))
- values(obj, rest)
+ values(object, rest)
else
let child = element(trie.trie-children, head(path), default: #f);
if (child)
- fob(child, tail(path), child.trie-object | obj,
+ real-find(child, tail(path), child.trie-object | object,
if (child.trie-object)
- if (empty?(tail(path))) #f else tail(path) end
+ tail(path)
else
rest
- end)
+ end if);
else
- values(obj, rest)
+ values(object, rest);
end
end
- end method fob;
- fob(trie, as(<list>, path), trie.trie-object, #f);
+ end method real-find;
+ real-find(trie, as(<list>, path), trie.trie-object, #());
end method find-object;
Modified: trunk/libraries/network/koala/sources/koala/vhost.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/vhost.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/vhost.dylan Sun Feb 17 19:09:45 2008
@@ -96,6 +96,7 @@
// *server-root*/www/<vhost-name>/. If name is the empty string then
// just *server-root*/www/.
slot document-root :: <directory-locator>;
+ slot dsp-root :: <directory-locator>;
// TODO: no need for this here. Even though ports can be specified inside
// the virtual host definition in the config file, we just need a
@@ -193,7 +194,8 @@
log-debug("name = %=, vhost-name = %=\n", name, vhost-name(vhost));
ensure-server-root();
// This may be overridden by a <document-root> spec in the config file.
- document-root(vhost) := subdirectory-locator(*server-root*, name);
+ vhost.document-root := subdirectory-locator(*server-root*, name);
+ vhost.dsp-root := subdirectory-locator(*server-root*, name);
// Add a spec that matches all urls.
add-directory-spec(vhost, root-directory-spec(vhost));
end;
@@ -298,15 +300,16 @@
end;
define method virtual-host
- (port :: <integer>) => (vhost :: false-or(<virtual-host>))
+ (port :: <integer>)
+ => (vhost :: false-or(<virtual-host>))
block (return)
for (vhost :: <virtual-host> keyed-by name in $virtual-hosts)
if (vhost-port(vhost) == port)
return(vhost)
- end
- end
+ end if;
+ end for;
end
-end;
+end method virtual-host;
define method directory-spec-matching
(vhost :: <virtual-host>, url :: <string>)
@@ -322,7 +325,7 @@
iff(dirspec-matches?(spec, url),
spec,
loop(tail(specs)));
- end;
+ end if;
end;
-end;
+end method directory-spec-matching;
More information about the chatter
mailing list