[Gd-chatter] r11175 - in branches/koala-config-cleanup/libraries/network/koala: . config sources/koala sources/xml-rpc-common
cgay at gwydiondylan.org
cgay at gwydiondylan.org
Mon Feb 12 13:40:40 CET 2007
Author: cgay
Date: Mon Feb 12 13:40:33 2007
New Revision: 11175
Removed:
branches/koala-config-cleanup/libraries/network/koala/sources/koala/dispatch.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/module.dylan
Modified:
branches/koala-config-cleanup/libraries/network/koala/config/koala-config.xml
branches/koala-config-cleanup/libraries/network/koala/sources/koala/config.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/dsp-main.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/dsp.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala-main.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala-unix.lid
branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala.lid
branches/koala-config-cleanup/libraries/network/koala/sources/koala/library-unix.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/library.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/resources.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/responders.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/server.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/static-files.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/utils.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/variables.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/vhost.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/koala/xml-rpc-server.dylan
branches/koala-config-cleanup/libraries/network/koala/sources/xml-rpc-common/library.dylan
branches/koala-config-cleanup/libraries/network/koala/to-do.txt
Log:
job: koala
Checkpointing so I can hack on Linux a bit.
Modified: branches/koala-config-cleanup/libraries/network/koala/config/koala-config.xml
==============================================================================
Binary files. No diff available.
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/config.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/config.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/config.dylan Mon Feb 12 13:40:33 2007
@@ -1,79 +1,191 @@
Module: httpi
-Synopsis: For processing the configuration init file, koala-config.xml
+Synopsis: Parse config file and create server configuration object.
Author: Carl Gay
Copyright: Copyright (c) 2001-2004 Carl L. Gay. All rights reserved.
License: Functional Objects Library Public License Version 1.0
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-/*
- * TODO: Should warn when unrecognized attributes are used.
- * Makes debugging your config file much easier sometimes.
- */
-
-define constant $koala-config-dir :: <string> = "config";
-define constant $koala-config-filename :: <string> = "koala-config.xml";
-
-// Holds the current vhost while config elements are being processed.
-define thread variable %vhost = $default-virtual-host;
-
-define inline function active-vhost
- () => (vhost :: <virtual-host>)
- if (%vhost == $default-virtual-host
- & ~ *fall-back-to-default-virtual-host?*)
- error("While processing the config file there was an attempt "
- "to set a value for the default virtual host, but fallback "
- "to the default virtual host is disabled so this is useless. "
- "Either enable fallback to the default virtual host or move "
- "all settings inside a <virtual-host></virtual-host> element.");
- else
- %vhost
- end
-end;
+define constant $config-directory-name :: <string> = "conf";
+define constant $log-directory-name :: <string> = "logs";
+define constant $document-directory-name :: <string> = "www";
+
+// This class holds all information that is configurable in a given Koala
+// <http-server> instance.
+//
+define class <http-server-configuration> (<object>)
+
+ // Whether the server should run in debug mode or not. If this is
+ // true then errors encountered while servicing HTTP requests will not
+ // be handled by the server itself. Normally the server will handle
+ // them and return an "internal server error" response. A good way to
+ // debug Dylan Server Pages. Can be enabled via the --debug
+ // command-line option.
+ slot debugging-enabled? :: <boolean> = #f,
+ init-keyword: #"debug?";
+
+ // Map from URL string to a response function. The leading slash is removed
+ // from URLs because it's easier to use merge-locators that way.
+ // TODO: this should be per vhost
+ // then 'define page' needs to specify vhost until dynamic
+ // library loading works. (ick.) once dynamic library loading
+ // works we use <module foo> inside <virtual-host> in the config
+ // and bind *virtual-host* while the library is loading?
+
+ constant slot url-map :: <string-trie> = make(<string-trie>, object: #f);
+
+ // The top of the directory tree under which the server's
+ // configuration, error, and log files are kept. Other pathnames are
+ // merged against this one, so if they're relative they will be
+ // relative to this. The server-root pathname is relative to the
+ // current working directory, unless changed in the config file.
+ slot server-root :: <directory-locator> = as(<file-locator>, "."),
+ init-keyword: #"server-root";
+
+ constant slot mime-type-map :: <table> = make(<table>);
+
+ // This is the "master switch" for auto-registration of URLs. If #f
+ // then URLs will never be automatically registered based on their
+ // file types. It defaults to #f to be safe.
+ // @see auto-register-map
+ slot auto-register-pages? :: <boolean> = #f,
+ init-keyword: #"auto-register-pages?";
+
+ // Maps from file extensions (e.g., "dsp") to functions that will
+ // register a URL responder for a URL. If a URL matching the file
+ // extension is requested, and the URL isn't registered yet, then the
+ // function for the URL's file type extension will be called to
+ // register the URL and then the URL will be processed normally. This
+ // mechanism is used, for example, to automatically export .dsp URLs
+ // as Dylan Server Pages so that it's not necessary to have a "define
+ // page" form for every page in a DSP application.
+ constant slot auto-register-map :: <string-table> = make(<string-table>);
+
+ // The vhost used if the request host doesn't match any other virtual host.
+ // Note that the document root may be changed when the config file is
+ // processed, so don't use it except during request processing.
+ constant slot default-virtual-host :: <virtual-host>
+ = begin
+ let stdout-log = make(<stream-log-target>, stream: *standard-output*);
+ make(<virtual-host>,
+ name: "default",
+ activity-log: stdout-log,
+ debug-log: stdout-log,
+ error-log: make(<stream-log-target>, stream: *standard-error*))
+ end;
+
+ // If this is true, then requests directed at hosts that don't match any
+ // explicitly named virtual host (i.e., something created with <virtual-host>
+ // in the config file) will use the default vhost. If this is #f when such a
+ // request is received, a Bad Request (400) response will be returned.
+ slot fall-back-to-default-virtual-host? :: <boolean> = #t;
+
+ // Maps host names to virtual hosts. Any host name not found in this
+ // table maps to default-virtual-host (contingent on the value of
+ // fall-back-to-default-virtual-host?).
+ constant slot virtual-hosts :: <string-table> = make(<string-table>);
+
+ // Since logging is done on a per-vhost basis, this hack is needed
+ // to make logging work before vhosts are initialized.
+ constant slot temp-log-target :: <log-target>
+ = make(<stream-log-target>, stream: *standard-output*);
+
+ // This may be set true by config file loading code, in which case
+ // start-server will abort startup.
+ slot abort-startup? :: <boolean> = #f;
+
+end class <http-server-configuration>;
+
+
+define method get-virtual-host
+ (config :: <http-server-configuration>, vhost-name :: <string>)
+ => (vhost :: false-or(<virtual-host>))
+ element(config.virtual-hosts, vhost-name, default: #f)
+end;
+
+// We want the config file values to override the slot default values and the
+// "make" keyword arguments to override the config file values. To accomplish
+// this, the config file parsing builds up a set of init arguments which are
+// appended to the make args.
+//
+define table *init-keyword-to-setter-map* = {
+ #"debug?" => debugging-enabled?-setter,
+ #"server-root" => server-root-setter,
+ #"auto-register-pages?" => auto-register-pages?-setter
+ };
+
+define method initialize
+ (config :: <http-server-configuration>, #rest args, #key config-file)
+ next-method();
+ // Config file overrides default slot values.
+ // Then init keywords override config file values.
+ if (config-file)
+ load-configuration-file(config, config-file);
+ // Now override config file settings with init-args again.
+ // Is there a better way?
+ local method argument-value (init-keyword)
+ block (return)
+ for (i from 0 by 2, while: i < args.size - 1)
+ if (args[i] == init-keyword)
+ return(args[i + 1]);
+ end if;
+ end for;
+ end block;
+ end method argument-value;
+ for (setter keyed-by init-keyword in *init-keyword-to-setter-map*)
+ setter(argument-value(init-keyword), config);
+ end for;
+ end if;
+end method initialize;
+
+//// CONFIG FILE PROCESSING
+
-define thread variable %dir = root-directory-spec($default-virtual-host);
+// Some variables for use during config file processing.
+define thread variable *config* = #f;
+define thread variable *vhost* = #f;
+define thread variable *directory* = #f;
+define thread variable *config-file* = #f;
-// Process the server config file, config.xml.
-// Assume a user directory structure like:
-// koala/
-// koala/bin // server executable and dlls
-// koala/www // default web document root
-// koala/config // koala-config.xml etc
-define method configure-server
- (config-file :: false-or(<string>))
- init-server-root();
- let defaults = merge-locators(merge-locators(as(<file-locator>, $koala-config-filename),
- as(<directory-locator>, $koala-config-dir)),
- *server-root*);
- let config-loc = as(<string>,
- merge-locators(as(<file-locator>, config-file | defaults),
- defaults));
+// todo -- Should warn when unrecognized attributes are used.
+// Makes debugging your config file much easier sometimes.
+
+define method load-configuration-file
+ (config :: <http-server-configuration>, filename :: <string>)
block (return)
- let handler <error> = method (c :: <error>, next-handler :: <function>)
- if (*debugging-server*)
- next-handler(); // decline to handle the error
- else
- log-error("Error loading config file: %=", c);
- return();
- end;
- end method;
- log-info("Loading server configuration from %s.", config-loc);
- let text = file-contents(config-loc);
+ local method error-handler (c :: <error>, next-handler :: <function>)
+ if (debugging-enabled?(config))
+ next-handler(); // decline to handle the error
+ else
+ log-error("Error loading config file: %=", c);
+ return();
+ end;
+ end method;
+ let handler <error> = error-handler;
+ let file = as(<file-locator>, filename);
+ log-info("Loading server configuration from %s.", filename);
+ let text = file-contents(file);
if (text)
- let xml :: xml$<document> = xml$parse-document(text);
- process-config-node(xml);
+ let xml :: xml$<document> = xml$parse-document(text, print-warnings?: #t);
+ let vhost = default-virtual-host(config);
+ dynamic-bind (*config* = config,
+ *config-file* = file,
+ *vhost* = vhost,
+ *directory* = root-directory-spec(vhost))
+ process-config-node(xml);
+ end;
else
- log-error("Server configuration file (%s) not found.", config-loc);
- *abort-startup?* := #t;
+ log-error("Server configuration file (%s) not found.", filename);
+ config.abort-startup? := #t;
end if;
end block;
-end method configure-server;
+end method load-configuration-file;
define function warn
(format-string, #rest format-args)
log-warning("%s: %s",
- $koala-config-filename,
+ as(<string>, *config-file*),
apply(format-to-string, format-string, format-args));
end;
@@ -112,7 +224,8 @@
// Note that the previous comment about the XML parser's class hierarchy
// applies here as well. Otherwise this would specialize node more tightly.
//
-define open generic process-config-element (node :: <object>, name :: <object>);
+define open generic process-config-element
+ (node :: <object>, name :: <object>);
define method process-config-element
(node :: xml$<element>, name :: <object>)
@@ -148,17 +261,21 @@
(node :: xml$<element>, name == #"virtual-host")
let name = get-attr(node, #"name");
if (name)
- let vhost = make(<virtual-host>, name: trim(name));
- add-virtual-host(name, vhost);
- dynamic-bind (%vhost = vhost,
- %dir = root-directory-spec(vhost))
- for (child in xml$node-children(node))
- process-config-element(child, xml$name(child))
+ let name = trim(name);
+ if (get-virtual-host(*config*, name))
+ warn("Ignoring duplicate virtual host %=", name);
+ else
+ let vhost = make(<virtual-host>, name: name);
+ *config*.virtual-hosts[name] := vhost;
+ dynamic-bind(*vhost* = vhost)
+ for (child in xml$node-children(node))
+ process-config-element(child, xml$name(child))
+ end;
end;
end;
else
- warn("Invalid <VIRTUAL-HOST> spec. "
- "The 'name' attribute must be specified.");
+ warn("Invalid <virtual-host> spec. "
+ "The 'name' attribute must be specified.");
end;
end;
@@ -166,39 +283,36 @@
(node :: xml$<element>, name == #"alias")
let name = get-attr(node, #"name");
if (name)
- if ($virtual-hosts[name])
- warn("There is already a virtual host named '%s'. "
- "Ignoring <ALIAS> element.");
+ let name = trim(name);
+ if (get-virtual-host(*config*, name))
+ warn("There is already a virtual host named %s. "
+ "Ignoring <alias> element.");
else
- add-virtual-host(name, active-vhost());
- end
+ *config*.virtual-hosts[name] := *vhost*;
+ end;
else
warn("Invalid <ALIAS> element. The 'name' attribute must be specified.");
end;
end;
-// I considered making this and debug-server be attributes on the
-// top-level <koala> element, but then it's impossible to turn on
-// logging first in a general way.
define method process-config-element
(node :: xml$<element>, name == #"default-virtual-host")
- bind (attr = get-attr(node, #"enabled"))
- when (attr)
- *fall-back-to-default-virtual-host?* := true-value?(attr)
- end;
- when (*fall-back-to-default-virtual-host?*)
- log-info("Fallback to the default virtual host is enabled.");
- end;
+ let attr = get-attr(node, #"enabled");
+ when (attr)
+ let enabled? = true-value?(attr);
+ *config*.fall-back-to-default-virtual-host? := enabled?;
+ log-info("Fallback to the default virtual host is %s.",
+ if (enabled?) "enabled" else "disabled" end);
end;
end;
define method process-config-element
(node :: xml$<element>, name == #"debug-server")
- bind (attr = get-attr(node, #"value"))
- when (attr)
- *debugging-server* := true-value?(attr);
- end;
- when (*debugging-server*)
+ let attr = get-attr(node, #"value");
+ when (attr)
+ let enabled? = true-value?(attr);
+ *config*.debugging-enabled? := enabled?;
+ when (enabled?)
warn("Server debugging is enabled. Server may crash if not run inside an IDE!");
end;
end;
@@ -211,64 +325,57 @@
block ()
let port = string-to-integer(attr);
if (port & positive?(port))
- vhost-port(active-vhost()) := port;
- log-info("VHost '%s': port = %d", vhost-name(active-vhost()), port);
+ vhost-port(*vhost*) := port;
+ log-info("Virtual host %s: port = %d", vhost-name(*vhost*), port);
else
error("jump to the exception clause :-)");
end;
exception (<error>)
- warn("VHost '%s': Invalid port %=", vhost-name(active-vhost()), attr);
+ warn("Virtual host %s: Invalid port %=", vhost-name(*vhost*), attr);
end;
else
- warn("Invalid <PORT> spec. The 'value' attribute must be specified.");
+ warn("Invalid <port> spec. The 'value' attribute must be specified.");
end;
end;
define method process-config-element
(node :: xml$<element>, name == #"auto-register")
- bind (attr = get-attr(node, #"enabled"))
- iff(attr,
- auto-register-pages?(active-vhost()) := true-value?(attr),
- warn("Invalid <AUTO-REGISTER> spec. "
- "The 'enabled' attribute must be specified as true or false."));
+ let attr = get-attr(node, #"enabled");
+ if (attr)
+ let enabled? = true-value?(attr);
+ auto-register-pages?(*vhost*) := enabled?;
+ log-info("Virtual host %s: documents will be auto-registered", vhost-name(*vhost*));
+ else
+ warn("Invalid <auto-register> spec. "
+ "The 'enabled' attribute must be specified as true or false.");
end;
end;
define method process-config-element
(node :: xml$<element>, name == #"server-root")
- // Note use of %vhost directly rather than active-vhost() here.
- // Don't want to blow out while setting *server-root* just because
- // the config doesn't allow fallback to the default vhost.
- if (%vhost == $default-virtual-host)
- let loc = get-attr(node, #"location");
- if (loc)
- init-server-root(location: loc);
- log-info("Server root set to %s", loc);
- else
- warn("Invalid <SERVER-ROOT> spec. "
- "The 'location' attribute must be specified.");
- *abort-startup?* := #t;
- end;
+ let filename = get-attr(node, #"location");
+ if (filename)
+ let loc = as(<directory-locator>, filename);
+ server-root(*vhost*) := as(<file-locator>, loc);
+ log-info("Server root set to %s", loc);
else
- warn("The <SERVER-ROOT> element is only valid at top-level "
- "(inside the <KOALA> element) in the koala config file. "
- "It will be ignored.");
+ warn("Invalid <server-root> spec. "
+ "The 'location' attribute must be specified.");
+ *config*.abort-startup? := #t;
end;
end;
define method process-config-element
(node :: xml$<element>, name == #"document-root")
- bind (loc = get-attr(node, #"location"))
- 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;
+ let loc = get-attr(node, #"location");
+ if(loc)
+ document-root(*vhost*)
+ := merge-locators(as(<directory-locator>, loc), server-root(*vhost*));
+ log-info("Virtual host %s: document root is %s.",
+ vhost-name(*vhost*), document-root(*vhost*));
+ else
+ warn("Invalid <document-root> spec. "
+ "The 'location' attribute must be specified.");
end;
end;
@@ -276,25 +383,27 @@
(node :: xml$<element>, name == #"log")
let type = get-attr(node, #"type");
if (~type)
- warn("<LOG> element missing 'type' attribute.");
+ warn("<log> element ignored ('type' attribute missing).");
elseif (~member?(type, #("debug", "activity", "error"),
test: string-equal?))
- warn("Log type %= not recognized. Should be 'debug', 'activity', "
- "or 'error'.", type);
+ warn("<log> element ignored (unrecognized 'type' attribute %=). "
+ "Type must be 'debug', 'activity', or 'error'.",
+ type);
else
let location = get-attr(node, #"location");
let max-size = get-attr(node, #"max-size");
+ let default-max-size = 1024 * 1024 * 20;
block ()
max-size := string-to-integer(max-size);
exception (e :: <error>)
- warn("<LOG> element has invalid max-size attribute (%s). "
- "The default (%d) will be used.", max-size);
+ warn("<log> element has invalid max-size attribute (%s). "
+ "The default (%d) will be used.", max-size, default-max-size);
end;
let log = iff(location,
make(<rolling-file-log-target>,
file: merge-locators(as(<file-locator>, location),
- *server-root*),
- max-size: max-size | 20000000),
+ *config*.server-root),
+ max-size: max-size | default-max-size),
make(<stream-log-target>,
stream: iff(string-equal?(type, "error"),
*standard-error*,
@@ -302,12 +411,12 @@
select (type by string-equal?)
"error", "errors"
- => %error-log-target(active-vhost()) := log;
+ => error-log-target(*vhost*) := log;
"activity"
- => %activity-log-target(active-vhost()) := log;
+ => activity-log-target(*vhost*) := log;
"debug"
- => %debug-log-target(active-vhost()) := log;
- let level = get-attr(node, #"level") | "info";
+ => debug-log-target(*vhost*) := log;
+ let level = get-attr(node, #"level") | "verbose";
let unrecognized = #f;
let class = select (level by string-equal?)
"copious" => <log-copious>;
@@ -317,11 +426,9 @@
"warning", "warnings" => <log-warning>;
"error", "errors" => <log-error>;
otherwise =>
- begin
- unrecognized := #t;
- <log-info>;
- end;
- end;
+ unrecognized := #t;
+ <log-verbose>;
+ end;
log-level(log) := make(class);
if (unrecognized)
warn("Unrecognized log level: %=", level);
@@ -337,43 +444,10 @@
end;
define method process-config-element
- (node :: xml$<element>, name == #"xml-rpc")
- let enable? = get-attr(node, #"enable");
- if (enable? & true-value?(enable?))
- bind (url = get-attr(node, #"url"))
- if (url)
- *xml-rpc-server-url* := url;
- log-info("XML-RPC URL set to %s.", url);
- end;
- end;
- bind (fault-code = get-attr(node, #"internal-error-fault-code"))
- if (fault-code)
- block ()
- let int-code = string-to-integer(fault-code);
- int-code & (*xml-rpc-internal-error-fault-code* := int-code);
- log-info("XML-RPC internal error fault code set to %d.", int-code);
- exception (<error>)
- warn("Invalid XML-RPC fault code, %=, specified. Must be an integer.",
- fault-code);
- end;
- end if;
- end;
- bind (debug = get-attr(node, #"debug"))
- *debugging-xml-rpc* := (debug & true-value?(debug));
- *debugging-xml-rpc* & log-info("XML-RPC debugging enabled.");
- end;
- init-xml-rpc-server();
- else
- log-info("XML-RPC disabled");
- end if;
-end;
-
-define method process-config-element
(node :: xml$<element>, name == #"module")
- bind (name = get-attr(node, #"name"))
- if (name)
- load-module(name);
- end;
+ let name = get-attr(node, #"name");
+ if (name)
+ load-module(name, *server*.configuration.server-root);
end;
end;
@@ -385,23 +459,28 @@
define method process-config-element
(node :: xml$<element>, name == #"mime-type-map")
let filename = get-attr(node, #"location");
- let mime-type-loc = as(<string>,
- merge-locators(as(<file-locator>,
- format-to-string("%s/%s",
- $koala-config-dir,
- filename)),
- *server-root*));
- let mime-text = file-contents(mime-type-loc);
+ if (~filename)
+ warn("<mime-type-map> element missing 'location' attribute. Element ignored.");
+ else
+ let map-loc = merge-locators(as(<file-locator>, filename),
+ subdirectory-locator(server-root(*vhost*),
+ $config-directory-name));
+ let mime-text = file-contents(map-loc);
if (mime-text)
- let mime-xml :: xml$<document> = xml$parse-document(mime-text);
- log-info("Loading mime-type map from %s.", mime-type-loc);
- log-info("%s",
- with-output-to-string (stream)
- xml$transform-document(mime-xml, state: $mime-type, stream: stream);
- end);
+ block ()
+ let mime-xml :: xml$<document> = xml$parse-document(mime-text);
+ log-info("Loading mime-type map from %s.", as(<string>, map-loc));
+ log-info("%s",
+ with-output-to-string (stream)
+ xml$transform-document(mime-xml, state: $mime-type, stream: stream);
+ end);
+ exception (ex :: <error>)
+ warn("Error parsing mime-type map %s: %s", filename, ex)
+ end;
else
- warn("mime-type map %s not found", mime-type-loc);
+ warn("mime-type map %s not found", map-loc);
end if;
+ end if;
end method;
define method xml$transform (node :: xml$<element>, name == #"mime-type",
@@ -409,7 +488,8 @@
let mime-type = get-attr(node, #"id");
for (child in xml$node-children(node))
if (xml$name(child) = #"extension")
- *mime-type-map*[as(<symbol>, xml$text(child))] := mime-type;
+ let tmap = mime-type-map(*vhost*);
+ tmap[as(<symbol>, xml$text(child))] := mime-type;
else
warn("Skipping: %s %s %s: not an extension node!",
mime-type, xml$name(child), xml$text(child));
@@ -418,7 +498,7 @@
end method xml$transform;
-// <directory location = "/"
+// <directory pattern = "/"
// allow-directory-listing = "yes"
// follow-symlinks = "yes"
// />
@@ -426,24 +506,24 @@
(node :: xml$<element>, name == #"directory")
let pattern = get-attr(node, #"pattern");
if (~pattern)
- warn("Invalid <DIRECTORY> spec. "
+ warn("Invalid <directory> spec. "
"The 'pattern' attribute must be specified.")
else
let dirlist? = get-attr(node, #"allow-directory-listing");
let follow? = get-attr(node, #"follow-symlinks");
- let root-spec = root-directory-spec(active-vhost());
- // TODO: the default value for these should really
- // be taken from the parent dirspec rather than from root-spec.
+ let root-spec = root-directory-spec(*vhost*);
+ let parent = *directory*;
let spec = make(<directory-spec>,
+ parent: parent,
pattern: pattern,
follow-symlinks?: iff(follow?,
true-value?(follow?),
- follow-symlinks?(root-spec)),
+ parent.follow-symlinks?),
allow-directory-listing?: iff(dirlist?,
true-value?(dirlist?),
- allow-directory-listing?(root-spec)));
- add-directory-spec(active-vhost(), spec);
- dynamic-bind (%dir = spec)
+ parent.allow-directory-listing?));
+ add-directory-spec(*vhost*, spec);
+ dynamic-bind (*directory* = spec)
for (child in xml$node-children(node))
process-config-element(child, xml$name(child));
end;
@@ -456,3 +536,89 @@
// <default-document>index.html</default-document>
// <response>301</response>???
+
+//// URL MAP STORE AND LOOKUP
+
+// Register a response function for a given URL. See find-responder.
+define /* exported */ method register-url
+ (config :: <http-server-configuration>, url :: <string>, target :: <function>,
+ #key replace?, prefix?)
+ 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(config.url-map, url, pair(target, prefix?), replace?: replace?);
+ end;
+ log-info("URL %s registered", url);
+end method register-url;
+
+// Find a responder function, if any.
+define method find-responder
+ (config :: <http-server-configuration>, url :: <string>)
+ => (responder :: false-or(<function>), #rest more)
+ local method maybe-auto-register (url)
+ when (config.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(config.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 = *server*.configuration.url-map;
+ let (responder, unmatched-part-of-url) = find-object(trie, path);
+ if (responder)
+ let fun = head(responder);
+ let prefix? = tail(responder);
+ values(fun, prefix?, unmatched-part-of-url)
+ else
+ maybe-auto-register(url)
+ end
+end find-responder;
+
+// 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
+// register-url (or register-page for DSPs) and should return a responder.
+//
+define function register-auto-responder
+ (config :: <http-server-configuration>, file-extension :: <string>, fn :: <function>,
+ #key replace? :: <boolean>)
+ if (~replace? & element(config.auto-register-map, file-extension, default: #f))
+ cerror("Replace the old auto-responder with the new one and continue.",
+ "An auto-responder is already defined for file extension %=.",
+ file-extension);
+ end;
+ config.auto-register-map[file-extension] := fn;
+end;
+
+// define responder test (config, "/test" /* , secure?: #t */ )
+// (request, response)
+// format(output-stream(response), "<html><body>test</body></html>");
+// end;
+define macro responder-definer
+ { define responder ?:name (?config:expression, ?url:expression)
+ (?request:variable, ?response:variable)
+ ?:body
+ end
+ }
+ => { define method ?name (?request, ?response) ?body end;
+ register-url(?config, ?url, ?name)
+ }
+
+ { define directory responder ?:name (?config:expression, ?url:expression)
+ (?request:variable, ?response:variable)
+ ?:body
+ end
+ }
+ => { define method ?name (?request, ?response) ?body end;
+ register-url(?config, ?url, ?name, prefix?: #t)
+ }
+end;
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/dsp-main.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/dsp-main.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/dsp-main.dylan Mon Feb 12 13:40:33 2007
@@ -6,21 +6,10 @@
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-//// Testing
-
-define function test-dsp
- () => ()
- // Nothing yet...
-end;
-
-
//// Initialization
begin
- register-auto-responder("dsp", auto-register-dylan-server-page);
- when (*debugging-dsp*)
- test-dsp();
- end;
+ register-auto-responder(config, "dsp", auto-register-dylan-server-page);
end;
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/dsp.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/dsp.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/dsp.dylan Mon Feb 12 13:40:33 2007
@@ -73,20 +73,27 @@
define open primary class <page> (<object>)
end;
-define method print-object
- (page :: <page>, stream)
- format(stream, "%s", page-url(page));
-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>);
+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>)
+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;
@@ -109,7 +116,8 @@
// Applications should call this to register a page for a particular URL.
define function register-page
- (url :: <string>, page :: <page>, #key replace?, prefix?)
+ (config :: <http-server-configuration>, url :: <string>, page :: <page>,
+ #key replace?)
=> (responder :: <function>)
bind (responder = curry(process-page, page))
let source = source-location(page);
@@ -118,7 +126,7 @@
iff(source,
sformat("source: %s", as(<string>, source)),
"dynamic"));
- register-url(url, responder, replace?: replace?, prefix?: prefix?);
+ register-url(config, url, responder, replace?: replace?);
*page-to-url-map*[page] := url;
responder
end
@@ -654,38 +662,29 @@
{ define page ?:name (?superclasses:*) (?make-args:*)
?slot-specs:*
end }
- => { page-aux(?name; ?superclasses; ?make-args; ?slot-specs);
- has-url?(?make-args) & register-page-urls("*" ## ?name ## "*", ?make-args)
- }
-
- { define directory page ?:name (?superclasses:*) (?make-args:*)
- ?slot-specs:*
- end }
- => { page-aux(?name; ?superclasses; ?make-args; ?slot-specs);
- has-url?(?make-args) & register-page-urls("*" ## ?name ## "*", ?make-args, prefix?: #t)
+ => { define class "<" ## ?name ## ">" (?superclasses) ?slot-specs end;
+ define variable "*" ## ?name ## "*" = make("<" ## ?name ## ">", ?make-args);
+ has-url?(?make-args) & register-page-urls("*" ## ?name ## "*", ?make-args);
}
-
end;
-define macro page-aux
- { page-aux(?:name; ?superclasses:*; ?make-args:*; ?slot-specs:*) }
- => { define class "<" ## ?name ## ">" (?superclasses) ?slot-specs end;
- define variable "*" ## ?name ## "*" = make("<" ## ?name ## ">", ?make-args) }
-end;
define function has-url? (#key url :: false-or(<string>), #all-keys)
=> (url-provided? :: <boolean>);
- url ~= #f
+ if (url)
+ #t
+ end;
end;
define function register-page-urls
- (page :: <page>, #key url :: <string>, alias, prefix?, #all-keys)
+ (config :: <http-server-configuration>, page :: <page>, #key url :: <string>, alias,
+ #all-keys)
=> (responder :: <function>)
- let responder = register-page(url, page, prefix?: prefix?);
+ let responder = register-page(url, page);
when (alias)
for (alias in iff(instance?(alias, <string>),
list(alias),
alias))
- register-url(alias, responder);
+ register-url(config, alias, responder);
end;
end;
responder
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala-main.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala-main.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala-main.dylan Mon Feb 12 13:40:33 2007
@@ -1,67 +1,62 @@
Module: httpi
-Synopsis: Library initialization code
+Synopsis: Initialization and startup
Author: Carl Gay
Copyright: Copyright (c) 2001-2004 Carl L. Gay. All rights reserved.
License: Functional Objects Library Public License Version 1.0
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-//// Testing
-
-define constant $debugging-koala :: <boolean> = #f;
-
-define function test-koala
- () => ()
- // Nothing yet...
-end;
-
//// Initialization
-define function init-koala ()
- when ($debugging-koala)
- test-koala();
- end;
-
- add-option-parser-by-type(*argument-list-parser*,
- <parameter-option-parser>,
- description: "Location of the koala configuration file",
- long-options: #("config"),
- short-options: #("c"));
- add-option-parser-by-type(*argument-list-parser*,
- <simple-option-parser>,
- description: "Display this help message",
- long-options: #("help"),
- short-options: #("h"));
- add-option-parser-by-type(*argument-list-parser*,
- <simple-option-parser>,
- description: "Enable debugging. Causes Koala to not handle "
- "most errors during request handling.",
- long-options: #("debug"));
-
- //init-server();
-end;
-
-begin
- init-koala();
-end;
-
-// This is defined here rather than in koala-app because wiki needs it too.
-define function koala-main ()
- let parser = *argument-list-parser*;
+define argument-parser <koala-command-line-parser> ()
+ option config-file = #f,
+ "", "Location of the Koala configuration file",
+ short: "c",
+ long: "config",
+ kind: <parameter-option-parser>;
+ option display-help?,
+ "", "Display this help message",
+ short: "h",
+ long: "help";
+ option debug-koala?,
+ "", "Enabled debugging. Causes Koala to not handle most errors during "
+ "request handling.",
+ long: "debug";
+ option listen-port,
+ "", "Port on which to listen for HTTP requests.",
+ short: "p",
+ long: "port",
+ kind: <parameter-option-parser>;
+end argument-parser <koala-command-line-parser>;
+
+// Command-line arguments parser. The expectation is that libraries that use
+// and extend koala (e.g., wiki) may want to add their own <option-parser>s to
+// this before calling koala-main().
+//
+define variable *command-line-parser* :: <koala-command-line-parser>
+ = make(<koala-command-line-parser>);
+
+// Parse the command line and start the server.
+//
+define function koala-main (#key description, wait? = #t)
+ let parser = *command-line-parser*;
parse-arguments(parser, application-arguments());
- if (option-value-by-long-name(parser, "help")
- | ~empty?(parser.regular-arguments))
- let desc = "The Koala web server, a multi-threaded web server with\n"
- "Dylan Server Pages and XML RPC, written in Dylan.";
+ if (parser.display-help?
+ | ~empty?(parser.regular-arguments))
+ let desc = description | "The Koala web server, a multi-threaded web server with\n"
+ "Dylan Server Pages and XML RPC, written in Dylan.";
print-synopsis(parser,
stream: *standard-output*,
- usage: "koala [options]",
+ usage: format-to-string("%s [options]", application-name()),
description: desc);
exit-application(0);
else
- if (option-value-by-long-name(parser, "debug"))
- *debugging-server* := #t;
- end;
- start-server(config-file: option-value-by-long-name(parser, "config"));
+ let config = make(<http-server-configuration>,
+ config-file: config-file(parser),
+ port: listen-port(parser),
+ debug?: debug-koala?(parser));
+ let server = make(<http-server>, configuration: config);
+ start-server(server, config, wait?: #t);
end;
end function koala-main;
+
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala-unix.lid
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala-unix.lid (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala-unix.lid Mon Feb 12 13:40:33 2007
@@ -17,7 +17,6 @@
session
static-files
server
- dispatch
dsp
dsp-taglib
xml-rpc-server
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala.lid
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala.lid (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/koala.lid Mon Feb 12 13:40:33 2007
@@ -17,7 +17,6 @@
session
static-files
server
- dispatch
dsp
dsp-taglib
database
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/library-unix.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/library-unix.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/library-unix.dylan Mon Feb 12 13:40:33 2007
@@ -24,7 +24,6 @@
use dylan-basics; // basic dylan utils
// use sql-odbc;
// use win32-kernel;
- use base64;
use memory-manager;
use getopt;
@@ -65,7 +64,6 @@
wrapping-inc!,
file-contents,
pset, // multiple-value-setq
- ignore-errors,
path-element-equal?,
parent-directory,
date-to-stream,
@@ -129,7 +127,7 @@
<rolling-file-log-target>,
<log-error>, <log-warning>, <log-info>, <log-debug>, <log-verbose>, <log-copious>,
log-error, log-warning, log-info, log-debug, log-debug-if, log-verbose, log-copious,
- log, log-raw,
+ log, log-raw, *standard-output-log-target*,
log-level, log-level-setter,
as-common-logfile-date;
@@ -150,8 +148,6 @@
// Basic server stuff
create
- http-server, // Get the active HTTP server object.
- ensure-server, // Get (or create) the active HTTP server object.
start-server,
stop-server,
register-url,
@@ -230,15 +226,18 @@
// Configuration
create
- process-config-element,
- get-attr;
+ load-configuration-file;
use xml-parser,
rename: { <element> => <xml-element> },
export: { <xml-element> };
// XML-RPC
create
- register-xml-rpc-method;
+ <xml-rpc-configuration>,
+ register-xml-rpc-server-url,
+ register-xml-rpc-method,
+ register-xml-rpc-test-methods,
+ register-xml-rpc-introspection-methods;
// Documents
create
@@ -267,22 +266,32 @@
// Debugging
create
- print-object;
+ print-object,
+ http-error-responder,
+ load-module-responder,
+ unload-module-responder;
- // files
+ // Files
create
static-file-responder;
+ // Statistics
+ create
+ general-stats-responder,
+ user-agent-responder;
+
// main() function
create
koala-main,
- *argument-list-parser*;
+ *command-line-parser*;
end module koala;
// Additional interface for extending the server
define module koala-extender
- create parse-header-value;
+ create
+ parse-header-value,
+ process-config-element, get-attr;
end;
define module httpi // http internals
@@ -328,7 +337,6 @@
use xml-parser,
prefix: "xml$";
use xml-rpc-common;
- use base64;
use getopt;
end module httpi;
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/library.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/library.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/library.dylan Mon Feb 12 13:40:33 2007
@@ -24,7 +24,6 @@
use dylan-basics; // basic dylan utils
use sql-odbc;
use win32-kernel;
- use base64;
use memory-manager;
use getopt;
@@ -65,7 +64,6 @@
wrapping-inc!,
file-contents,
pset, // multiple-value-setq
- ignore-errors,
path-element-equal?,
parent-directory,
date-to-stream,
@@ -129,7 +127,7 @@
<rolling-file-log-target>,
<log-error>, <log-warning>, <log-info>, <log-debug>, <log-verbose>, <log-copious>,
log-error, log-warning, log-info, log-debug, log-debug-if, log-verbose, log-copious,
- log, log-raw,
+ log, log-raw, *standard-output-log-target*,
log-level, log-level-setter,
as-common-logfile-date;
@@ -150,8 +148,6 @@
// Basic server stuff
create
- http-server, // Get the active HTTP server object.
- ensure-server, // Get (or create) the active HTTP server object.
start-server,
stop-server,
register-url,
@@ -230,15 +226,18 @@
// Configuration
create
- process-config-element,
- get-attr;
+ load-configuration-file;
use xml-parser,
rename: { <element> => <xml-element> },
export: { <xml-element> };
// XML-RPC
create
- register-xml-rpc-method;
+ <xml-rpc-configuration>,
+ register-xml-rpc-server-url,
+ register-xml-rpc-method,
+ register-xml-rpc-test-methods,
+ register-xml-rpc-introspection-methods;
// Documents
create
@@ -267,22 +266,32 @@
// Debugging
create
- print-object;
+ print-object,
+ http-error-responder,
+ load-module-responder,
+ unload-module-responder;
- // files
+ // Files
create
static-file-responder;
+ // Statistics
+ create
+ general-stats-responder,
+ user-agent-responder;
+
// main() function
create
koala-main,
- *argument-list-parser*;
+ *command-line-parser*;
end module koala;
// Additional interface for extending the server
define module koala-extender
- create parse-header-value;
+ create
+ parse-header-value,
+ process-config-element, get-attr;
end;
define module httpi // http internals
@@ -329,7 +338,6 @@
prefix: "xml$";
use xml-rpc-common;
use win32-kernel, import: { LoadLibrary, FreeLibrary };
- use base64;
use getopt;
end module httpi;
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/resources.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/resources.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/resources.dylan Mon Feb 12 13:40:33 2007
@@ -177,7 +177,7 @@
// XXX We're in module utilities here, and have no way of figuring out
// the log target. Maybe we need to model log events as conditions.
-define variable *temp-log-target*
+define variable *standard-output-log-target*
= make(<stream-log-target>, stream: *standard-output*);
/*
@@ -222,7 +222,7 @@
inc!(pool.active-count);
return (resource);
else
- log-debug(*temp-log-target*,
+ log-debug(*standard-output-log-target*,
"Resource full. Allocating non-pooled instance. %=",
resource-class);
apply(new-resource, resource-class, init-args)
@@ -276,7 +276,7 @@
add!(pool.inactive-resources, resource);
inc!(pool.inactive-count);
else
- log-warning(*temp-log-target*,
+ log-warning(*standard-output-log-target*,
"Can't return resource %= to pool. Hopefully it will be GCed.",
resource);
end;
@@ -286,7 +286,7 @@
define method describe-pool
(pool :: <resource-pool>)
- log-debug(*temp-log-target*,
+ log-debug(*standard-output-log-target*,
"active: %d,%d, inactive: %d,%d - %s",
pool.active-resources.size, pool.active-count,
pool.inactive-resources.size, pool.inactive-count,
@@ -306,9 +306,9 @@
end;
describe-pool(pool);
end;
- log-debug(*temp-log-target*, "*** Testing resource pools");
+ log-debug(*standard-output-log-target*, "*** Testing resource pools");
for (i from 1 to 6)
- log-debug(*temp-log-target*, ""); // blank line
+ log-debug(*standard-output-log-target*, ""); // blank line
doit(class);
end;
end;
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/responders.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/responders.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/responders.dylan Mon Feb 12 13:40:33 2007
@@ -9,8 +9,8 @@
// General server statistics
//
-define responder general-stats-responder ("/koala/stats")
- (request, response)
+define method general-stats-responder
+ (request :: <request>, response :: <response>)
let stream = output-stream(response);
let server = request.request-server;
format(stream, "<html><body>");
@@ -23,8 +23,8 @@
// Show some stats about what user-agents have connected to the server.
//
-define responder user-agent-responder ("/koala/user-agents")
- (request, response)
+define method user-agent-responder
+ (request :: <request>, response :: <response>)
let stream = output-stream(response);
format(stream, "<html><body>");
for (count keyed-by agent in user-agent-stats(request-server(request)))
@@ -36,8 +36,8 @@
// Return an HTTP error code, for testing purposes.
// e.g., /koala/http-error?code=503
//
-define responder http-error-responder ("/koala/http-error")
- (request, response)
+define method http-error-responder
+ (request :: <request>, response :: <response>)
let code-string = get-query-value("code");
let code = string-to-integer(code-string);
signal(make(<http-error>,
@@ -46,36 +46,22 @@
format-arguments: vector(code-string)));
end;
-// Shutdown the server. You definately don't want this active in a
-// production setting.
-//
-/*
-define responder shutdown-responder ("/koala/shutdown")
- (request, response)
- let stream = output-stream(response);
- let server = request.request-server;
- format(stream, "<html><body>Shutting down...</body></html>");
- force-output(stream);
- stop-server(abort: #t);
-end;
-*/
-
// Load a module
//
-define responder load-module-responder ("/koala/load-module")
- (request, response)
+define method load-module-responder
+ (request :: <request>, response :: <response>)
load/unload-module(request, response, #"load");
end;
// Unload a module
//
-define responder unload-module-responder ("/koala/unload-module")
- (request, response)
+define method unload-module-responder
+ (request :: <request>, response :: <response>)
load/unload-module(request, response, #"unload");
end;
define function load/unload-module
- (request, response, op :: one-of(#"load", #"unload"))
+ (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");
@@ -84,7 +70,7 @@
write(stream, "You must specify the name of a module in the URL.\n");
else
if (op == #"load")
- load-module(module-name);
+ load-module(module-name, *server*.configuration.server-root);
format(stream, "Module %s loaded.");
else
unload-module(module-name);
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/server.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/server.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/server.dylan Mon Feb 12 13:40:33 2007
@@ -10,12 +10,6 @@
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;
-
define constant $server-header-value = concatenate($server-name, "/", $server-version);
// This is needed to handle sockets shutdown.
@@ -27,7 +21,7 @@
end);
end;
-define class <server> (<sealed-constructor>)
+define class <http-server> (<sealed-constructor>)
constant slot server-lock :: <lock>,
required-init-keyword: lock:;
// Support for shutting down listeners.
@@ -40,6 +34,15 @@
constant slot listener-shutdown-timeout :: <real> = 15;
constant slot client-shutdown-timeout :: <real> = 15;
+ constant slot configuration :: <http-server-configuration>
+ = make(<http-server-configuration>),
+ init-keyword: #"configuration";
+
+ // todo -- Everything below here should be moved out of this class.
+ // Some into <http-server-configuration> and some probably
+ // into a stats class of some sort.
+
+ // todo -- move the next 3 slots into <http-server-configuration>
// Parameters
slot max-listeners :: <integer> = 1;
slot request-class :: subclass(<basic-request>) = <basic-request>;
@@ -51,20 +54,11 @@
// RFC 2616, 5.1.1
constant slot allowed-methods :: <sequence> = #(#"GET", #"POST", #"HEAD");
- // Map from URL string to a response function. The leading slash is removed
- // from URLs because it's easier to use merge-locators that way.
- // TODO: this should be per vhost
- // then 'define page' needs to specify vhost until dynamic
- // library loading works. (ick.) once dynamic library loading
- // works we use <module foo> inside <virtual-host> in the config
- // and bind *virtual-host* while the library is loading?
-
- constant slot url-map :: <string-trie> = make(<string-trie>, object: #f);
-
// pathname translations
//slot pathname-translations :: <sequence> = #();
//// Statistics
+ // todo -- move these elsewhere
slot connections-accepted :: <integer> = 0; // Connections accepted
constant slot user-agent-stats :: <string-table> = make(<string-table>);
@@ -73,7 +67,7 @@
end;
define sealed method make
- (c == <server>, #rest keys, #key) => (server :: <server>)
+ (c == <http-server>, #rest keys, #key) => (server :: <http-server>)
let lock = make(<lock>);
let listeners-notification = make(<notification>, lock: lock);
let clients-notification = make(<notification>, lock: lock);
@@ -86,7 +80,7 @@
// Keep some stats on user-agents
define method note-user-agent
- (server :: <server>, user-agent :: <string>)
+ (server :: <http-server>, user-agent :: <string>)
with-lock (server.server-lock)
let agents = user-agent-stats(server);
agents[user-agent] := element(agents, user-agent, default: 0) + 1;
@@ -114,7 +108,7 @@
end release-client;
define class <listener> (<sealed-constructor>)
- constant slot listener-server :: <server>,
+ constant slot listener-server :: <http-server>,
required-init-keyword: server:;
constant slot listener-port :: <integer>,
required-init-keyword: port:;
@@ -135,7 +129,7 @@
end class <listener>;
define class <client> (<sealed-constructor>)
- constant slot client-server :: <server>,
+ constant slot client-server :: <http-server>,
required-init-keyword: server:;
constant slot client-listener :: <listener>,
required-init-keyword: listener:;
@@ -167,7 +161,7 @@
end;
define inline function request-server (request :: <basic-request>)
- => (server :: <server>)
+ => (server :: <http-server>)
request.request-client.client-server
end;
@@ -184,97 +178,110 @@
*/
define variable *sockets-started?* :: <boolean> = #f;
+define constant $start-sockets-lock = make(<lock>);
define function ensure-sockets-started ()
- unless (*sockets-started?*)
- start-sockets();
- //start-ssl-sockets();
- *sockets-started?* := #t;
+ with-lock ($start-sockets-lock)
+ unless (*sockets-started?*)
+ start-sockets();
+ //start-ssl-sockets();
+ *sockets-started?* := #t;
+ end;
end;
end;
-define variable *server* :: <server> = make(<server>);
-define variable *server-lock* = make(<lock>); // overkill, but so what.
-
-define function ensure-server () => (server :: <server>)
- with-lock (*server-lock*)
- *server* | (*server* := make(<server>))
- end
-end ensure-server;
-
-define function http-server () => (server :: <server>)
- *server*
-end;
-
define variable *next-listener-id* :: <integer> = 0;
-
-// This is called when the library is loaded (from main.dylan).
-define function init-server
- (#key listeners :: <integer> = 1,
- request-class :: subclass(<basic-request>)
- = *default-request-class*,
- config-file)
- let server :: <server> = ensure-server();
- server.max-listeners := listeners;
- server.request-class := request-class;
- configure-server(config-file);
- log-info("%s HTTP Server starting up", $server-name);
- ensure-sockets-started(); // TODO: Can this be moved into start-server?
- log-info("Server root directory is %s", *server-root*);
- when (*auto-register-pages?*)
- log-info("Auto-register enabled");
- end;
- run-init-functions();
-end init-server;
+define variable *default-request-class* :: subclass(<basic-request>) = <request>;
// API
-// This is what client libraries call to start the server.
+// This is what client libraries call to start a server.
//
define function start-server
- (#key config-file :: false-or(<string>))
+ (server :: <http-server>, config :: <http-server-configuration>,
+ #key wait? :: <boolean> = #t,
+ // todo -- move these into config
+ max-listeners :: <integer> = 1,
+ request-class :: subclass(<basic-request>) = *default-request-class*)
=> (started? :: <boolean>)
- if (~config-file)
- let args = application-arguments();
- let pos = find-key(args, method (x) as-lowercase(x) = "--config" end);
- if (pos & (args.size > pos + 1))
- config-file := args[pos + 1];
- end;
- end if;
- init-server(config-file: config-file);
- if (*abort-startup?*)
+ log-info("%s HTTP Server starting up", $server-name);
+ ensure-sockets-started();
+ server.max-listeners := max-listeners;
+ server.request-class := request-class;
+ log-info("Server root directory is %s", config.server-root);
+ when (config.auto-register-pages?)
+ log-info("Auto-register enabled");
+ end;
+ run-init-functions();
+ let server-started? :: <boolean> = #f;
+ if (config.abort-startup?)
log-error("Server startup aborted due to the previous errors");
- #f
else
let ports = #();
- for (vhost keyed-by name in $virtual-hosts)
- ports := add!(ports, vhost-port(vhost))
+ for (vhost keyed-by name in config.virtual-hosts)
+ ports := add!(ports, vhost.vhost-port)
end;
- if (*fall-back-to-default-virtual-host?*)
- ports := add!(ports, vhost-port($default-virtual-host));
+ if (config.fall-back-to-default-virtual-host?)
+ ports := add!(ports, config.default-virtual-host.vhost-port);
end;
if (empty?(ports))
log-error("No ports to listen on! No virtual hosts were specified "
"in the config file and fallback to the default vhost is "
"disabled.");
- #f
else
// temporary code...
let port = ports[0];
- while (start-http-listener(*server*, port))
- *server-running?* := #t;
+ while (start-http-listener(server, port))
+ server-started? := #t;
end;
- // Apparently when the main thread dies in a FunDev Dylan application
- // the application exits without waiting for spawned threads to die,
- // so join-listeners keeps the main thread alive until all listeners die.
- join-listeners(*server*);
- *server-running?* := #f;
- #t
- end if
- end if
+ if (wait?)
+ // Don't exit until all listener threads die.
+ join-listeners(server);
+ end;
+ end if;
+ end if;
+ server-started?
end function start-server;
+define function start-http-listener (server :: <http-server>, port :: <integer>)
+ => (started? :: <boolean>)
+ let server-lock = server.server-lock;
+ let listener = #f;
+ local method run-listener-top-level ()
+ with-lock (server-lock) end; // Wait for setup to finish.
+ //---TODO: Include the thread name in the log message.
+ log-info("Listener starting up");
+ let listener :: <listener> = listener;
+ block ()
+ listener-top-level(listener);
+ cleanup
+ log-info("Listener on port %d shutting down", port);
+ close(listener.listener-socket, abort?: #t);
+ release-listener(listener);
+ end;
+ end method;
+ let started? = #f;
+ with-lock (server-lock)
+ let listeners = server.server-listeners;
+ when (listeners.size < server.max-listeners)
+ log-debug("Creating a new listener thread.");
+ let socket = make(<server-socket>, port: port);
+ let thread = make(<thread>,
+ name: format-to-string("HTTP Listener #%s/%d",
+ *next-listener-id*, port),
+ function: run-listener-top-level);
+ wrapping-inc!(*next-listener-id*);
+ listener := make(<listener>,
+ server: server, port: port, socket: socket, thread: thread);
+ add!(server.server-listeners, listener);
+ started? := #t
+ end;
+ end;
+ started?
+end start-http-listener;
+
+
define function join-listeners
- (server :: <server>)
+ (server :: <http-server>)
// Don't use join-thread, because no timeouts, so could hang.
// eh?
block (return)
@@ -289,20 +296,15 @@
end;
end;
-// If there's ever a UI, it should have a button to call this.
-//
-define function stop-server (#key abort)
- let server = *server*;
- when (server)
- abort-listeners(server);
- when (~abort)
- join-clients(server);
- end;
- abort-clients(server);
+define function stop-server (server :: <http-server>, #key abort?)
+ abort-listeners(server);
+ when (~abort?)
+ join-clients(server);
end;
+ abort-clients(server);
end;
-define function abort-listeners (server :: <server>)
+define function abort-listeners (server :: <http-server>)
iterate next ()
let listener = with-lock (server.server-lock)
any?(method (listener :: <listener>)
@@ -332,7 +334,7 @@
// At this point all listeners have been shut down, so shouldn't
// be spawning any more clients.
-define function abort-clients (server :: <server>, #key abort)
+define function abort-clients (server :: <http-server>, #key abort)
with-lock (server.server-lock)
for (client in server.clients)
close(client.client-socket, abort: abort);
@@ -344,7 +346,7 @@
end;
end abort-clients;
-define function join-clients (server :: <server>, #key timeout)
+define function join-clients (server :: <http-server>, #key timeout)
=> (clients-left :: <integer>)
with-lock (server.server-lock)
empty?(server.clients)
@@ -355,42 +357,6 @@
end;
end join-clients;
-define function start-http-listener (server :: <server>, port :: <integer>)
- => (started? :: <boolean>)
- let server-lock = server.server-lock;
- let listener = #f;
- local method run-listener-top-level ()
- with-lock (server-lock) end; // Wait for setup to finish.
- //---TODO: Include the thread name in the log message.
- log-info("Listener starting up");
- let listener :: <listener> = listener;
- block ()
- listener-top-level(listener);
- cleanup
- log-info("Listener on port %d shutting down", port);
- close(listener.listener-socket, abort?: #t);
- release-listener(listener);
- end;
- end method;
- let started? = #f;
- with-lock (server-lock)
- let listeners = server.server-listeners;
- when (listeners.size < server.max-listeners)
- log-debug("Creating a new listener thread.");
- let socket = make(<server-socket>, port: port);
- let thread = make(<thread>,
- name: format-to-string("HTTP Listener #%s/%d", *next-listener-id*, port),
- function: run-listener-top-level);
- wrapping-inc!(*next-listener-id*);
- listener := make(<listener>,
- server: server, port: port, socket: socket, thread: thread);
- add!(server.server-listeners, listener);
- started? := #t
- end;
- end;
- started?
-end start-http-listener;
-
define function listener-top-level (listener :: <listener>)
with-socket-thread (server?: #t)
// loop spawning clients until listener socket gets broken.
@@ -428,7 +394,7 @@
// so that it will return from 'accept' with some error, which we should
// catch gracefully..
//---TODO: need to handle errors.
-// Listen and spawn handlers until listener socket gets broken.
+// Listen and spawn handlers until listener socket breaks.
//
define function do-http-listen (listener :: <listener>)
let server = listener.listener-server;
@@ -457,7 +423,7 @@
let client :: <client> = client;
block ()
with-socket-thread ()
- handler-top-level(client);
+ handle-request-top-level(client);
end;
cleanup
ignore-errors(<socket-condition>,
@@ -526,8 +492,7 @@
element(request.request-headers, name, default: #f)
end;
-define variable *default-request-class* :: subclass(<basic-request>) = <request>;
-
+define thread variable *server* :: false-or(<http-server>) = #f;
define thread variable *request* :: false-or(<request>) = #f;
define thread variable *response* :: false-or(<response>) = #f;
@@ -540,19 +505,21 @@
define inline function current-response () => (response :: <response>) *response* end;
// Called (in a new thread) each time an HTTP request is received.
-define function handler-top-level
+define function handle-request-top-level
(client :: <client>)
- dynamic-bind (*request* = #f)
+ dynamic-bind (*request* = #f,
+ *server* = client.client-server)
block (exit-request-handler)
while (#t) // keep alive loop
let request :: <basic-request>
= make(client.client-server.request-class, client: client);
*request* := request;
+ let config :: <http-server-configuration> = *server*.configuration;
with-simple-restart("Skip this request and continue with the next")
block (exit-inner)
let handler <error>
= method (c :: <error>, next-handler :: <function>)
- if (*debugging-server*)
+ if (config.debugging-enabled?)
next-handler(); // decline to handle the error
else
send-error-response(request, c);
@@ -561,7 +528,7 @@
end;
let handler <stream-error>
= method (c :: <error>, next-handler :: <function>)
- if (*debugging-server*)
+ if (config.debugging-enabled?)
next-handler(); // decline to handle the error
else
log-error("A stream error occurred. %=", c);
@@ -575,7 +542,7 @@
request.request-query-values := query-values;
read-request(request);
dynamic-bind (*request-query-values* = query-values,
- *virtual-host* = virtual-host(request))
+ *virtual-host* = virtual-host(config, request))
log-debug("Virtual host for request is '%s'",
vhost-name(*virtual-host*));
invoke-handler(request);
@@ -602,7 +569,7 @@
end while;
end block;
end dynamic-bind;
-end handler-top-level;
+end handle-request-top-level;
// This method takes care of parsing the request headers and signalling any
// errors therein.
@@ -662,7 +629,8 @@
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);
+ let config :: <http-server-configuration> = request.request-server.configuration;
+ let (resp, prefix?, tail) = find-responder(config, 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?)
@@ -838,103 +806,6 @@
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;
-
-// 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
-// register-url (or register-page for DSPs) and should return a responder.
-//
-define function register-auto-responder
- (file-extension :: <string>, f :: <function>, #key replace? :: <boolean>)
- if (~replace? & element(*auto-register-map*, file-extension, default: #f))
- cerror("Replace the old auto-responder with the new one and continue.",
- "An auto-responder is already defined for file extension %=.",
- file-extension);
- end;
- *auto-register-map*[file-extension] := f;
-end;
-
-// define responder test ("/test" /* , secure?: #t */ )
-// (request, response)
-// format(output-stream(response), "<html><body>test</body></html>");
-// end;
-define macro responder-definer
- { define responder ?:name (?url:expression)
- (?request:variable, ?response:variable)
- ?:body
- end
- }
- => { define method ?name (?request, ?response) ?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;
- 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
@@ -1122,19 +993,14 @@
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);
+ (module-name :: <string>, module-directory :: <directory-locator>)
+ // Modules are loaded from <server-root>/modules/.
+ let path = as(<string>,
+ merge-locators(as(<file-locator>,
+ format-to-string("%s/%s",
+ $module-directory, module-name)),
+ module-directory));
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
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/static-files.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/static-files.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/static-files.dylan Mon Feb 12 13:40:33 2007
@@ -151,10 +151,12 @@
// Get MIME Type for file name
-define method get-mime-type (locator :: <locator>) => (mime-type :: <string>)
+define method get-mime-type
+ (config :: <http-server-configuration>, locator :: <locator>)
+ => (mime-type :: <string>)
let extension = locator-extension(locator);
let sym = extension & ~empty?(extension) & as(<symbol>, extension);
- let mime-type = ((sym & element(*mime-type-map*, sym, default: #f))
+ let mime-type = ((sym & element(mime-type-map(config), sym, default: #f))
| default-static-content-type(*virtual-host*));
log-debug("extension = %=, sym = %=, mime-type = %=", extension, sym, mime-type);
mime-type;
@@ -166,7 +168,8 @@
(request :: <request>, response :: <response>, locator :: <locator>)
with-open-file(in-stream = locator, direction: #"input", if-does-not-exist: #f,
element-type: <byte>)
- let mime-type = get-mime-type(locator);
+ let config = *server*.configuration;
+ let mime-type = get-mime-type(config, locator);
add-header(response, "Content-Type", mime-type);
let props = file-properties(locator);
add-header(response, "Last-Modified",
@@ -231,8 +234,9 @@
end if;
write(stream, "\t\t\t\t<tr>\n");
format(stream, "\t\t\t\t<td class=\"name\"><a href=\"%s\">%s</a></td>\n", link, link);
+ let config = *server*.configuration;
let mime-type = iff(type = #"file",
- get-mime-type(locator),
+ get-mime-type(config, locator),
"");
format(stream, "\t\t\t\t<td class=\"mime-type\">%s</td>\n", mime-type);
for (key in #[#"size", #"modification-date", #"author"],
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/utils.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/utils.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/utils.dylan Mon Feb 12 13:40:33 2007
@@ -210,8 +210,9 @@
if (trie.trie-object = #f | replace?)
trie.trie-object := object;
else
- signal(make(<trie-error>,
- format-string: format-to-string("Trie already contains an object for the given path (%=).", path)))
+ let fmt = format-to-string("Trie already contains an object for the "
+ "given path (%=).", path);
+ signal(make(<trie-error>, format-string: fmt))
end;
else
let first-path = rest-path[0];
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/variables.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/variables.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/variables.dylan Mon Feb 12 13:40:33 2007
@@ -1,71 +1,7 @@
Module: httpi
Synopsis: Some globals that don't belong anywhere else in particular.
- Most are configurable in the koala-config.xml file.
Author: Carl Gay
Copyright: Copyright (c) 2001 Carl L. Gay. All rights reserved.
License: Functional Objects Library Public License Version 1.0
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-
-// Whether the server should run in debug mode or not. If this is true then
-// errors encountered while servicing HTTP requests will not be handled by the
-// server itself. Normally the server will handle them and return an "internal
-// server error" response. A good way to debug Dylan Server Pages. Can be
-// enabled via the --debug command-line option.
-define variable *debugging-server* :: <boolean> = #f;
-
-// The top of the directory tree under which the server's configuration, error,
-// and log files are kept. Other pathnames are merged against this one, so if
-// they're relative they will be relative to this. The server-root pathname is
-// relative to the koala executable, unless changed in the config file.
-define variable *server-root* :: false-or(<directory-locator>) = #f;
-
-define function ensure-server-root ()
- when (~*server-root*)
- let exe-dir = locator-directory(as(<file-locator>, application-filename()));
- *server-root* := parent-directory(exe-dir);
- end;
-end;
-
-define function init-server-root (#key location)
- ensure-server-root();
- when (location)
- *server-root* := merge-locators(as(<directory-locator>, location),
- *server-root*);
- end;
-end;
-
-
-// TODO: The follow 3 should probably be per vhost.
-
-define variable *mime-type-map* :: <table> = make(<table>);
-
-// This is the "master switch" for auto-registration of URLs. If #f then URLs will
-// never be automatically registered based on their file types. It defaults to #f
-// to be safe.
-// @see *auto-register-map*
-define variable *auto-register-pages?* :: <boolean> = #f;
-
-// Maps from file extensions (e.g., "dsp") to functions that will register a URL
-// responder for a URL. If a URL matching the file extension is requested, and
-// the URL isn't registered yet, then the function for the URL's file type extension
-// will be called to register the URL and then the URL will be processed normally.
-// This mechanism is used, for example, to automatically export .dsp URLs as Dylan
-// Server Pages so that it's not necessary to have a "define page" form for every
-// page in a DSP application.
-define variable *auto-register-map* :: <string-table>
- = make(<string-table>);
-
-// This is #t when the server is listening for requests and #f otherwise.
-define variable *server-running?* :: <boolean> = #f;
-
-// Since logging is done on a per-vhost basis, this hack is needed
-// to make logging work before vhosts are initialized.
-define variable *temp-log-target*
- = make(<stream-log-target>, stream: *standard-output*);
-
-// Command-line arguments parser. The expectation is that libraries that use
-// and extend koala (e.g., wiki) may want to add their own <option-parser>s to
-// this before calling koala-main().
-define variable *argument-list-parser* :: <argument-list-parser>
- = make(<argument-list-parser>);
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/vhost.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/vhost.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/vhost.dylan Mon Feb 12 13:40:33 2007
@@ -9,22 +9,28 @@
// Some methods to make logging slightly more convenient by not having
// to always pass log-target(*virtual-host*).
define method log-copious (format-string, #rest format-args)
- apply(%log-copious, *temp-log-target* | debug-log-target(*virtual-host*), format-string, format-args);
+ apply(%log-copious, *standard-output-log-target* | debug-log-target(*virtual-host*),
+ format-string, format-args);
end;
define method log-verbose (format-string, #rest format-args)
- apply(%log-verbose, *temp-log-target* | debug-log-target(*virtual-host*), format-string, format-args);
+ apply(%log-verbose, *standard-output-log-target* | debug-log-target(*virtual-host*),
+ format-string, format-args);
end;
define method log-debug (format-string, #rest format-args)
- apply(%log-debug, *temp-log-target* | debug-log-target(*virtual-host*), format-string, format-args);
+ apply(%log-debug, *standard-output-log-target* | debug-log-target(*virtual-host*),
+ format-string, format-args);
end;
define method log-info (format-string, #rest format-args)
- apply(%log-info, *temp-log-target* | debug-log-target(*virtual-host*), format-string, format-args);
+ apply(%log-info, *standard-output-log-target* | debug-log-target(*virtual-host*),
+ format-string, format-args);
end;
define method log-warning (format-string, #rest format-args)
- apply(%log-warning, *temp-log-target* | error-log-target(*virtual-host*), format-string, format-args);
+ apply(%log-warning, *standard-output-log-target* | error-log-target(*virtual-host*),
+ format-string, format-args);
end;
define method log-error (format-string, #rest format-args)
- apply(%log-error, *temp-log-target* | error-log-target(*virtual-host*), format-string, format-args);
+ apply(%log-error, *standard-output-log-target* | error-log-target(*virtual-host*),
+ format-string, format-args);
end;
@@ -32,6 +38,9 @@
constant slot dirspec-pattern :: <string>,
required-init-keyword: pattern:;
+ constant slot directory-parent :: false-or(<directory-spec>),
+ required-init-keyword: parent:;
+
// TODO:
// If this regular expression is the first to match the request URL
// then this directory spec will be used.
@@ -80,9 +89,12 @@
constant slot vhost-name :: <string>,
required-init-keyword: name:;
+ constant slot http-server-configuration :: <http-server-configuration>,
+ required-init-keyword: configuration:;
+
// The root of the web document hierarchy. By default, this will be
- // *server-root*/www/<vhost-name>/. If name is the empty string then
- // just *server-root*/www/.
+ // {config}.server-root/www/<vhost-name>/. If name is the empty string then
+ // just {config}.server-root/www/.
slot document-root :: <directory-locator>;
// TODO: no need for this here. Even though ports can be specified inside
@@ -109,6 +121,7 @@
// See initialize(<virtual-host>).
constant slot root-directory-spec :: <directory-spec>
= make(<directory-spec>,
+ parent: #f,
pattern: "/*");
// Whether or not to include a Server: header in all responses. Most people
@@ -152,40 +165,31 @@
// Log targets. If these are #f then the default virtual host's
// log target is used. They are never #f in $default-virtual-host.
- slot %activity-log-target :: false-or(<log-target>) = #f,
+ slot activity-log-target :: false-or(<log-target>) = #f,
init-keyword: #"activity-log";
- slot %error-log-target :: false-or(<log-target>) = #f,
+ slot error-log-target :: false-or(<log-target>) = #f,
init-keyword: #"error-log";
- slot %debug-log-target :: false-or(<log-target>) = #f,
+ slot debug-log-target :: false-or(<log-target>) = #f,
init-keyword: #"debug-log";
end class <virtual-host>;
define method initialize
- (vhost :: <virtual-host>, #key name, #all-keys)
+ (vhost :: <virtual-host>, #key)
next-method();
- 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);
+ let name = vhost.vhost-name;
+ let config = vhost.http-server-configuration;
+ vhost.document-root := subdirectory-locator(config.server-root, name);
// Add a spec that matches all urls.
- add-directory-spec(vhost, root-directory-spec(vhost));
-end;
-
-define method activity-log-target
- (vhost :: <virtual-host>) => (target :: <log-target>)
- vhost.%activity-log-target | $default-virtual-host.%activity-log-target
-end;
-
-define method debug-log-target
- (vhost :: <virtual-host>) => (target :: <log-target>)
- vhost.%debug-log-target | $default-virtual-host.%debug-log-target
-end;
-
-define method error-log-target
- (vhost :: <virtual-host>) => (target :: <log-target>)
- vhost.%error-log-target | $default-virtual-host.%error-log-target
+ add-directory-spec(vhost, vhost.root-directory-spec);
+ vhost.activity-log-target
+ := vhost.activity-log-target | vhost.http-server-configuration.default-virtual-host.activity-log-target;
+ vhost.error-log-target
+ := vhost.error-log-target | vhost.http-server-configuration.default-virtual-host.error-log-target;
+ vhost.debug-log-target
+ := vhost.debug-log-target | vhost.http-server-configuration.default-virtual-host.debug-log-target;
end;
define method add-directory-spec
@@ -197,50 +201,20 @@
end));
end;
-// The vhost used if the request host doesn't match any other virtual host.
-// Note that the document root may be changed when the config file is
-// processed, so don't use it except during request processing.
-//
-define constant $default-virtual-host :: <virtual-host>
- = begin
- let stdout-log = make(<stream-log-target>, stream: *standard-output*);
- make(<virtual-host>,
- name: "default",
- activity-log: stdout-log,
- debug-log: stdout-log,
- error-log: make(<stream-log-target>, stream: *standard-error*))
- end;
+//// VIRTUAL HOST ACCESS
-// If this is true, then requests directed at hosts that don't match any
-// explicitly named virtual host (i.e., something created with <virtual-host>
-// in the config file) will use the default vhost. If this is #f when such a
-// request is received, a Bad Request (400) response will be returned.
-//
-define variable *fall-back-to-default-virtual-host?* :: <boolean> = #t;
-
-// Maps host names to virtual hosts. Any host name not found in this
-// table maps to $default-virtual-host (contingent on the value of
-// *fall-back-to-default-virtual-host?*).
-define constant $virtual-hosts :: <string-table> = make(<string-table>);
-
-define thread variable *virtual-host* :: <virtual-host> = $default-virtual-host;
-
-begin
- *temp-log-target* := #f;
-end;
-
-define method add-virtual-host
- (name :: <string>, vhost :: <virtual-host>)
- $virtual-hosts[name] := vhost;
-end;
+define thread variable *virtual-host* :: <virtual-host>
+ = make(<virtual-host>, configuration: make(<http-server-configuration>));
define method virtual-host
- (name :: <string>) => (vhost :: false-or(<virtual-host>))
- element($virtual-hosts, name, default: #f)
+ (config :: <http-server-configuration>, name :: <string>)
+ => (vhost :: false-or(<virtual-host>))
+ element(config.virtual-hosts, name, default: #f)
end;
define method virtual-host
- (request :: <request>) => (vhost :: false-or(<virtual-host>))
+ (config :: <http-server-configuration>, request :: <request>)
+ => (vhost :: false-or(<virtual-host>))
let host-spec = request-host(request);
local method die ()
bad-request(message: format-to-string("Unknown virtual host: %s",
@@ -256,26 +230,29 @@
log-debug("error parsing port in host spec");
die();
end;
- let vhost = virtual-host(host) | (*fall-back-to-default-virtual-host?*
- & $default-virtual-host);
+ let vhost = (virtual-host(config, host)
+ | (config.fall-back-to-default-virtual-host?
+ & config.default-virtual-host));
// TODO: If this is an HTTPS request and no port is specified, make sure
// vhost-port(vhost) == 443
if (vhost & ((~port & vhost-port(vhost) == 80)
| port == vhost-port(vhost)))
vhost
else
- die();
- end;
+ die()
+ end
else
- (*fall-back-to-default-virtual-host?* & $default-virtual-host)
- | die()
+ iff (config.fall-back-to-default-virtual-host?,
+ config.default-virtual-host,
+ die())
end
end;
define method virtual-host
- (port :: <integer>) => (vhost :: false-or(<virtual-host>))
+ (config :: <http-server-configuration>, port :: <integer>)
+ => (vhost :: false-or(<virtual-host>))
block (return)
- for (vhost :: <virtual-host> keyed-by name in $virtual-hosts)
+ for (vhost :: <virtual-host> keyed-by name in config.virtual-hosts)
if (vhost-port(vhost) == port)
return(vhost)
end
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/koala/xml-rpc-server.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/koala/xml-rpc-server.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/koala/xml-rpc-server.dylan Mon Feb 12 13:40:33 2007
@@ -6,85 +6,91 @@
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-// Determines whether the server will respond to XML-RPC requests.
-// This variable is configurable in koala-config.xml
-//
-define variable *xml-rpc-enabled?* :: <boolean> = #t;
-
-// This variable is configurable in koala-config.xml
-//
-define variable *xml-rpc-server-url* :: <string> = "/RPC2";
+// Exported
+define class <xml-rpc-configuration> (<object>)
-// This is the fault code that will be returned to the caller if
-// any error other than <xml-rpc-fault> is thrown during the execution
-// of the RPC. For example, if there's a parse error in the XML
-// that's received. If users want to return a fault code they
-// should use the xml-rpc-fault method.
-//
-// This variable is configurable in koala-config.xml
-//
-define variable *xml-rpc-internal-error-fault-code* :: <integer> = 0;
-
-// This is the registered XML-RPC responder function.
-// ---TODO: Shouldn't really even register the responder if XML-RPC is disabled.
-//
-define function respond-to-xml-rpc-request
- (request :: <request>, response :: <response>)
- when (*xml-rpc-enabled?*)
- set-content-type(response, "text/xml");
- // All responses start with a valid XML document header.
- write(output-stream(response),
- "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>");
- block ()
- let xml = request-content(request);
- when (*debugging-xml-rpc*)
- log-debug("Received XML-RPC call:\n %s", xml);
- end;
- let doc = xml$parse-document(xml);
- let (method-name, args) = parse-xml-rpc-call(doc);
- log-debug("method-name = %=, args = %=", method-name, args);
- let fun = lookup-xml-rpc-method(method-name)
- | xml-rpc-fault(*xml-rpc-internal-error-fault-code*,
- "Method not found: %=",
- method-name);
- send-xml-rpc-result(response, apply(fun, args));
- exception (err :: <xml-rpc-fault>)
- send-xml-rpc-fault-response(response, err);
- exception (err :: <error>)
- send-xml-rpc-fault-response
- (response,
- make(<xml-rpc-fault>,
- fault-code: *xml-rpc-internal-error-fault-code*,
- format-string: condition-format-string(err),
- format-arguments: condition-format-arguments(err)));
+ // This is the fault code that will be returned to the caller if
+ // any error other than <xml-rpc-fault> is thrown during the execution
+ // of the RPC. For example, if there's a parse error in the XML
+ // that's received. If users want to return a fault code they
+ // should use the xml-rpc-fault method.
+ // Exported
+ slot xml-rpc-internal-error-fault-code :: <integer> = 0,
+ init-keyword: internal-error-fault-code:;
+
+ // Maps method names to response functions. If namespaces are used then
+ // the value may be another <string-table> containing the mapping for that
+ // namespace.
+ // Exported
+ constant slot xml-rpc-methods :: <string-table> = make(<string-table>),
+ init-keyword: methods:;
+
+ // Exported
+ slot debugging-enabled? :: <boolean> = #f,
+ init-keyword: debug?:;
+
+end class <xml-rpc-configuration>;
+
+
+define method respond-to-xml-rpc-request
+ (xml-rpc-config :: <xml-rpc-configuration>,
+ request :: <request>,
+ response :: <response>)
+ set-content-type(response, "text/xml");
+ // All responses start with a valid XML document header.
+ write(output-stream(response),
+ "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>");
+ block ()
+ let xml = request-content(request);
+ when (xml-rpc-config.debugging-enabled?)
+ // Could probably do with some more fine-grained control over debug content.
+ log-debug("XML-RPC: Received call:\n %s", xml);
end;
- end when;
-end;
-
-define constant $xml-rpc-methods :: <string-table> = make(<string-table>);
+ let doc = xml$parse-document(xml);
+ let (method-name, args) = parse-xml-rpc-call(doc);
+ log-debug("XML-RPC: method-name = %=, args = %=", method-name, args);
+ let fun = lookup-xml-rpc-method(xml-rpc-config, method-name)
+ | xml-rpc-fault(xml-rpc-config.xml-rpc-internal-error-fault-code,
+ "Method not found: %=",
+ method-name);
+ send-xml-rpc-result(xml-rpc-config, response, apply(fun, args));
+ exception (err :: <xml-rpc-fault>)
+ send-xml-rpc-fault-response(xml-rpc-config, response, err);
+ exception (err :: <error>)
+ let fault = make(<xml-rpc-fault>,
+ fault-code: xml-rpc-config.xml-rpc-internal-error-fault-code,
+ format-string: condition-format-string(err),
+ format-arguments: condition-format-arguments(err));
+ send-xml-rpc-fault-response(xml-rpc-config, response, fault);
+ end;
+end method respond-to-xml-rpc-request;
define method lookup-xml-rpc-method
- (method-name :: <string>)
+ (xml-rpc-config :: <xml-rpc-configuration>, method-name :: <string>)
=> (f :: false-or(<function>))
- element($xml-rpc-methods, method-name, default: #f)
+ // todo -- Implement namespaces (methods named x.y.z)
+ element(xml-rpc-config.xml-rpc-methods, method-name, default: #f)
end;
-// ---TODO: xml-rpc-method-definer
+// todo -- xml-rpc-method-definer
//
+// Exported
define method register-xml-rpc-method
- (name :: <string>, f :: <function>, #key replace? :: <boolean>)
- if (~replace? & lookup-xml-rpc-method(name))
+ (xml-rpc-config :: <xml-rpc-configuration>, name :: <string>, f :: <function>,
+ #key replace? :: <boolean>)
+ if (~replace? & lookup-xml-rpc-method(xml-rpc-config, name))
signal(make(<xml-rpc-error>,
format-string: "An XML-RPC method named %= already exists.",
format-arguments: vector(name)))
else
- $xml-rpc-methods[name] := f;
+ xml-rpc-config.xml-rpc-methods[name] := f;
log-info("XML-RPC method registered: %=", name);
end;
end;
define method send-xml-rpc-fault-response
- (response :: <response>, fault :: <xml-rpc-fault>)
+ (xml-rpc-config :: <xml-rpc-configuration>, response :: <response>,
+ fault :: <xml-rpc-fault>)
let stream = output-stream(response);
let value = make(<table>);
value["faultCode"] := fault-code(fault);
@@ -95,16 +101,17 @@
end;
define method send-xml-rpc-result
- (response :: <response>, result :: <object>)
+ (xml-rpc-config :: <xml-rpc-configuration>, response :: <response>,
+ result :: <object>)
let stream = output-stream(response);
write(stream, "<methodResponse><params><param><value>");
let xml = with-output-to-string(s)
to-xml(result, s);
end;
- *debugging-xml-rpc*
- & log-debug("Sending XML: %=", xml);
+ if (xml-rpc-config.debugging-enabled?)
+ log-debug("XML-RPC: Sending %=", xml);
+ end;
write(stream, xml);
- //to-xml(result, stream);
write(stream, "</value></param></params></methodResponse>\r\n");
end;
@@ -128,15 +135,28 @@
values(method-name, args)
end;
-define function init-xml-rpc-server
- () => ()
- when (*xml-rpc-enabled?*)
- register-url(*xml-rpc-server-url*, respond-to-xml-rpc-request);
-
- // Provide a basic way to test the server.
- register-xml-rpc-method("ping", method () #t end, replace?: #t);
- register-xml-rpc-method("echo", method (#rest args) args end, replace?: #t);
- end;
+// Exported
+define method register-xml-rpc-server-url
+ (config :: <http-server-configuration>,
+ url :: <string>,
+ xml-rpc-config :: <xml-rpc-configuration>,
+ #key replace?)
+ register-url(config, url, curry(respond-to-xml-rpc-request, xml-rpc-config),
+ replace?: replace?, prefix?: #f);
+end;
+
+// Exported
+define method register-xml-rpc-test-methods
+ (xml-rpc-config :: <xml-rpc-configuration>)
+ register-xml-rpc-method(xml-rpc-config, "ping", method () #t end, replace?: #t);
+ register-xml-rpc-method(xml-rpc-config, "echo", method (#rest args) args end, replace?: #t);
+end;
+
+// Exported
+define method register-xml-rpc-introspection-methods
+ (xml-rpc-config :: <xml-rpc-configuration>)
+ // todo --
+ signal(make(<xml-rpc-error>,
+ format-string: "XML-RPC introspection not yet implemented"));
end;
-
Modified: branches/koala-config-cleanup/libraries/network/koala/sources/xml-rpc-common/library.dylan
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/sources/xml-rpc-common/library.dylan (original)
+++ branches/koala-config-cleanup/libraries/network/koala/sources/xml-rpc-common/library.dylan Mon Feb 12 13:40:33 2007
@@ -6,10 +6,21 @@
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
define library xml-rpc-common
- use common-dylan;
- use io;
- use system; // for date module
- use xml-parser;
+ use common-dylan, import: {
+ dylan,
+ common-extensions
+ };
+ use io, import: {
+ format,
+ format-out,
+ streams
+ };
+ use system, import: {
+ date
+ };
+ use xml-parser, import: {
+ xml-parser
+ };
use dylan-basics;
export xml-rpc-common;
end;
Modified: branches/koala-config-cleanup/libraries/network/koala/to-do.txt
==============================================================================
--- branches/koala-config-cleanup/libraries/network/koala/to-do.txt (original)
+++ branches/koala-config-cleanup/libraries/network/koala/to-do.txt Mon Feb 12 13:40:33 2007
@@ -1,9 +1,16 @@
Koala To-Do List
----------------
+* Make koala as easy to use as an HTTP server in Python. Something like this:
+ use koala;
+ let config = make(<config>, locator: "/tmp/koala-config.xml"); // optional
+ let server = make(<http-server>, config: config);
+ register-url("/foo", method (request, response) ... end;
+ start-server(server, in-new-thread?: #f);
+
* Ability to bind to a specific IP address.
-* Thread pool. Can be expensive to allocate/deallocate a threads.
+* Thread pool. Can be expensive to allocate/deallocate threads.
* Fix security issues...
More information about the chatter
mailing list