[chatter] r11792 - in trunk/libraries: collection-extensions collection-extensions/test network/http-client network/http-client/http-client-test-suite network/http-client/http-protocol-test-suite network/koala network/koala/config network/koala/docs network/koala/sources/examples/koala-basics network/koala/sources/koala network/koala/sources/koala-app network/web-framework network/wiki registry/generic uri
cgay at mccarthy.opendylan.org
cgay at mccarthy.opendylan.org
Fri May 2 12:58:08 CEST 2008
Author: cgay
Date: Fri May 2 12:58:04 2008
New Revision: 11792
Added:
trunk/libraries/network/http-client/
trunk/libraries/network/http-client/http-client-test-suite/
trunk/libraries/network/http-client/http-client-test-suite/http-client-test-suite.dylan (contents, props changed)
trunk/libraries/network/http-client/http-client-test-suite/http-client-test-suite.lid (contents, props changed)
trunk/libraries/network/http-client/http-client-test-suite/library.dylan (contents, props changed)
trunk/libraries/network/http-client/http-client.dylan (contents, props changed)
trunk/libraries/network/http-client/http-client.lid (contents, props changed)
trunk/libraries/network/http-client/http-protocol-test-suite/
trunk/libraries/network/http-client/http-protocol-test-suite/http-protocol-test-suite.dylan (contents, props changed)
trunk/libraries/network/http-client/http-protocol-test-suite/http-protocol-test-suite.lid (contents, props changed)
trunk/libraries/network/http-client/http-protocol-test-suite/library.dylan (contents, props changed)
trunk/libraries/network/http-client/library.dylan (contents, props changed)
trunk/libraries/registry/generic/http-client (contents, props changed)
trunk/libraries/registry/generic/http-client-test-suite (contents, props changed)
trunk/libraries/registry/generic/http-protocol-test-suite (contents, props changed)
trunk/libraries/registry/generic/koala-test-suite (contents, props changed)
Modified:
trunk/libraries/collection-extensions/sequence-utils.dylan
trunk/libraries/collection-extensions/test/sequence-utils-suite.dylan
trunk/libraries/network/koala/README.txt
trunk/libraries/network/koala/config/koala-config.xml
trunk/libraries/network/koala/docs/rfc2616-http-1.1.txt
trunk/libraries/network/koala/sources/examples/koala-basics/library.dylan
trunk/libraries/network/koala/sources/examples/koala-basics/main.dylan
trunk/libraries/network/koala/sources/koala-app/koala-app.dylan
trunk/libraries/network/koala/sources/koala-app/library.dylan
trunk/libraries/network/koala/sources/koala/config.dylan
trunk/libraries/network/koala/sources/koala/errors.dylan
trunk/libraries/network/koala/sources/koala/header-values.dylan
trunk/libraries/network/koala/sources/koala/koala-main.dylan
trunk/libraries/network/koala/sources/koala/library-unix.dylan
trunk/libraries/network/koala/sources/koala/library.dylan
trunk/libraries/network/koala/sources/koala/server.dylan
trunk/libraries/network/koala/sources/koala/static-files.dylan
trunk/libraries/network/koala/sources/koala/string-utils.dylan
trunk/libraries/network/koala/sources/koala/urls.dylan
trunk/libraries/network/koala/sources/koala/variables.dylan
trunk/libraries/network/koala/sources/koala/vhost.dylan
trunk/libraries/network/web-framework/changes.dylan
trunk/libraries/network/web-framework/library.dylan
trunk/libraries/network/wiki/admin.dylan
trunk/libraries/network/wiki/classes.dylan
trunk/libraries/network/wiki/library.dylan
trunk/libraries/network/wiki/parser.dylan
trunk/libraries/network/wiki/wiki.dylan
trunk/libraries/uri/uri.dylan
Log:
job: koala
Begin changes to make Koala more usable as a library rather than a
standalone app:
* Added some test suites that so far do almost nothing.
* Clients now call make(<http-server>, ... config settings...). So far the only
setting is document-root. There is no longer an error on startup if a config
file isn't specified.
* Pass port, background, debug args to start-server. There will only be support
for one port (plus ssl-port, eventually).
* Start moving some globals into <http-server> and/or thread variables.
* Partially unbroke wiki.
Modified: trunk/libraries/collection-extensions/sequence-utils.dylan
==============================================================================
--- trunk/libraries/collection-extensions/sequence-utils.dylan (original)
+++ trunk/libraries/collection-extensions/sequence-utils.dylan Fri May 2 12:58:04 2008
@@ -591,6 +591,7 @@
// SPLIT-AT -- split a sequence at a token.
//
+// Replace with common-dylan:split. --cgay
define function split-at
(sequence :: <sequence>, token, #key test = \=)
=> split-sequence :: <sequence>;
Modified: trunk/libraries/collection-extensions/test/sequence-utils-suite.dylan
==============================================================================
--- trunk/libraries/collection-extensions/test/sequence-utils-suite.dylan (original)
+++ trunk/libraries/collection-extensions/test/sequence-utils-suite.dylan Fri May 2 12:58:04 2008
@@ -67,7 +67,7 @@
define test split-string-3
(description: "Split a string with trailing comma")
let result = split-at("a,bc,def,", ',');
- check-equal("Split contains three elements", 4, result.size);
+ check-equal("Split contains four elements", 4, result.size);
check-equal("First string is \"a\"", "a", result[0]);
check-equal("Second string is \"bc\"", "bc", result[1]);
check-equal("Thrid string is \"def\"", "def", result[2]);
Added: trunk/libraries/network/http-client/http-client-test-suite/http-client-test-suite.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/http-client/http-client-test-suite/http-client-test-suite.dylan Fri May 2 12:58:04 2008
@@ -0,0 +1,69 @@
+module: http-client-test-suite
+
+define suite http-client-test-suite ()
+ test test-simple-http-get;
+end suite http-client-test-suite;
+
+define responder hello ("/http-test/hello")
+ output("hello")
+end;
+
+define test test-simple-http-get ()
+ check-equal("GET of /hello returns \"hello\"?",
+ simple-http-get("http://localhost:8080/http-test/hello"),
+ "hello");
+end test test-simple-http-get;
+
+define function main ()
+ let parser = make(<argument-list-parser>);
+ add-option-parser-by-type(parser,
+ <parameter-option-parser>,
+ description: "Document root for the HTTP client test pages",
+ long-options: #("document-root"),
+ short-options: #("d"));
+ add-option-parser-by-type(parser,
+ <parameter-option-parser>,
+ description: "Koala port number to use",
+ long-options: #("port"),
+ short-options: #("p"));
+ add-option-parser-by-type(parser,
+ <simple-option-parser>,
+ description: "Display this help message",
+ long-options: #("help"),
+ short-options: #("h"));
+ add-option-parser-by-type(parser,
+ <simple-option-parser>,
+ description: "Enable debugging. Causes Koala to not handle "
+ "most errors during request handling.",
+ long-options: #("debug"));
+
+ parse-arguments(parser, application-arguments());
+ if (option-value-by-long-name(parser, "help")
+ | ~empty?(parser.regular-arguments))
+ print-synopsis(parser,
+ *standard-output*,
+ usage: format-to-string("%s [options]", application-name()),
+ description: application-name());
+ else
+ let port = string-to-integer(option-value-by-long-name(parser, "port") | "8080");
+ let docroot = option-value-by-long-name(parser, "document-root")
+ // Change default to /var/www/http-test or something
+ | "c:/cgay/dylan/trunk/libraries/network/http-client/tests/www";
+ let http-server = make(<http-server>,
+ document-root: docroot);
+ // The following shouldn't return until ready for service.
+ start-server(http-server,
+ port: port,
+ background: #t,
+ debug: option-value-by-long-name(parser, "debug"));
+ // The above returns immediately (for now), so give it time to start up.
+ sleep(2);
+ run-test-application(http-client-test-suite);
+ stop-server(http-server);
+ end;
+end function main;
+
+begin
+ main();
+end;
+
Added: trunk/libraries/network/http-client/http-client-test-suite/http-client-test-suite.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/network/http-client/http-client-test-suite/http-client-test-suite.lid Fri May 2 12:58:04 2008
@@ -0,0 +1,3 @@
+library: http-client-test-suite
+files: library.dylan
+ http-client-test-suite.dylan
Added: trunk/libraries/network/http-client/http-client-test-suite/library.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/http-client/http-client-test-suite/library.dylan Fri May 2 12:58:04 2008
@@ -0,0 +1,33 @@
+module: dylan-user
+
+define library http-client-test-suite
+ use common-dylan;
+ use testworks;
+ use http-client;
+ use koala,
+ import: { koala };
+ use command-line-parser;
+ use io,
+ import: { standard-io };
+ use system,
+ import: { threads };
+
+ export http-client-test-suite;
+
+end library http-client-test-suite;
+
+define module http-client-test-suite
+ use common-dylan;
+ use testworks;
+ use http-client;
+ use koala;
+ use command-line-parser;
+ use standard-io,
+ import: { *standard-output* };
+ use threads,
+ import: { sleep };
+
+ export http-client-test-suite;
+
+end module http-client-test-suite;
+
Added: trunk/libraries/network/http-client/http-client.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/http-client/http-client.dylan Fri May 2 12:58:04 2008
@@ -0,0 +1,161 @@
+Module: http-client
+
+/// Parameters.
+
+define variable *debug-http* :: <boolean> = #t;
+
+define constant $default-http-port :: <integer> = 80;
+
+
+/// Conditions
+
+define class <http-error> (<error>)
+ constant slot http-error-message :: <string>,
+ required-init-keyword: #"message";
+ constant slot http-error-code :: <string>,
+ init-value: #f,
+ init-keyword: #"code";
+end class <http-error>;
+
+// FIXME: This doesn't change the way the error message is displayed in the IDE.
+// Why not?
+define method condition-to-string
+ (cond :: <http-error>) => (string :: <string>)
+ if (cond.http-error-code)
+ format-to-string("%s - %s", cond.http-error-code, cond.http-error-message)
+ else
+ cond.http-error-message
+ end
+end method condition-to-string;
+
+// RFC 2616, 6.6.1
+define function read-http-status-line
+ (stream :: <stream>)
+ => (http-version :: <symbol>, status-code :: <byte-string>, reason :: <byte-string>)
+ let status-line = read-line(stream);
+ when (*debug-http*)
+ format-out("%s\n", status-line);
+ end;
+ let parts = split(status-line, ' ', count: 3);
+ assert(parts.size == 3, "Invalid HTTP status line received: %=", status-line);
+ let (http-version, status-code, reason-phrase) = apply(values, parts);
+ values(as(<symbol>, http-version),
+ status-code,
+ reason-phrase)
+end function read-http-status-line;
+
+/// Session-level interface.
+
+// API
+define macro with-http-stream
+ { with-http-stream (?:variable to ?host:expression, #rest ?args:*) ?:body end }
+ => { let http-stream = #f;
+ block ()
+ http-stream := open-http-stream(?host, ?args);
+ let ?variable = http-stream;
+ ?body
+ cleanup
+ if (http-stream)
+ close-http-stream(http-stream);
+ end;
+ end; }
+end macro with-http-stream;
+
+// API
+define method open-http-stream
+ (host, #key port = $default-http-port) => (stream :: <stream>)
+ let stream = make(<tcp-socket>, host: host, port: port);
+ stream
+end;
+
+// API
+define method close-http-stream
+ (stream :: <stream>) => ()
+ close(stream);
+end;
+
+// API
+define method write-http-get
+ (stream :: <stream>, host :: <byte-string>, path :: <byte-string>, #rest headers)
+ => ()
+ format-http-line(stream, "GET %s HTTP/1.1", path);
+ // RFC 2616, 19.6.1.1 -- HTTP/1.1 clients MUST include the Host header.
+ format-http-line(stream, "Host: %s", host);
+ for (i from 0 below size(headers) by 2)
+ let key = headers[i];
+ let val = headers[i + 1];
+ format-http-line(stream, "%s: %s", key, val);
+ end;
+ format-http-line(stream, "");
+end method write-http-get;
+
+// API
+// Return the content of the given URL as a string.
+//
+define method simple-http-get
+ (url :: <byte-string>) => (content :: <string>)
+ let url :: <url> = as(<url>, url);
+/*
+ if (~instance?(url, <server-url>))
+ error("You must specify the remote host in the URL.");
+ end;
+ let request-uri = locator-path(url);
+ if (instance?(url, <cgi-url>))
+ request-uri := concatenate(request-uri, "?", locator-cgi-string(url));
+ end;
+ if (instance?(url, <file-index-url>))
+ request-uri := concatenate(request-uri, "#", locator-index);
+ end;
+*/
+ let directory = locator-directory(url);
+ let server = locator-server(directory);
+ let host = locator-host(server);
+ with-http-stream(stream to host, port: locator-port(server))
+ write-http-get(stream, host, locator-as-string(<string>, url));
+ let (http-version, status, reason-phrase) = read-http-status-line(stream);
+ if (status[0] == '2')
+ read-http-response-header(stream);
+ read-to-end(stream)
+ elseif (member?(status[0], "45"))
+ error(make(<http-error>, message: reason-phrase, code: status));
+ else
+ error(make(<http-error>,
+ message: format-to-string("HTTP response code %s not yet implemented",
+ status),
+ code: status));
+ end
+ end
+end method simple-http-get;
+
+// API
+define method read-http-response-header
+ (stream :: <stream>) => ()
+ read-http-response-header-as(<string>, stream);
+end;
+
+// API
+define method read-http-response-header-as
+ (type :: subclass(<string>), stream :: <stream>) => ()
+ with-output-to-string (string-stream)
+ let line = #f;
+ while ((line := read-line(stream)) ~= "")
+ if (*debug-http*)
+ format-out("%s\n", line);
+ end;
+ write-line(string-stream, line);
+ end;
+ end;
+end method;
+
+define method format-http-line
+ (stream :: <stream>, template :: <string>, #rest args) => ()
+ when (*debug-http*)
+ apply(format-out, template, args);
+ format-out("\n");
+ end;
+ apply(format, stream, template, args);
+ write(stream, "\r\n");
+end method;
+
+// eof
+
Added: trunk/libraries/network/http-client/http-client.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/network/http-client/http-client.lid Fri May 2 12:58:04 2008
@@ -0,0 +1,3 @@
+library: http-client
+files: library.dylan
+ http-client.dylan
Added: trunk/libraries/network/http-client/http-protocol-test-suite/http-protocol-test-suite.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/http-client/http-protocol-test-suite/http-protocol-test-suite.dylan Fri May 2 12:58:04 2008
@@ -0,0 +1,61 @@
+Module: http-protocol-test-suite
+Synopsis: Test suite to validate conformance to HTTP 1.1 protocol spec (RFC 2616)
+Author: Carl Gay
+
+define suite http-protocol-test-suite ()
+ suite http-method-test-suite;
+end suite http-protocol-test-suite;
+
+define suite http-method-test-suite ()
+ test test-get-method;
+ test test-post-method;
+ test test-head-method;
+ test test-put-method;
+ test test-delete-method;
+ test test-trace-method;
+ test test-connect-method;
+end;
+
+define test test-get-method ()
+ check-equal("GET /hello yields \"hello\"",
+ simple-http-get(test-url("hello")),
+ "hello");
+end test test-get-method;
+
+define test test-post-method ()
+end test test-post-method;
+
+define test test-head-method ()
+end test test-head-method;
+
+define test test-put-method ()
+end test test-put-method;
+
+define test test-delete-method ()
+end test test-delete-method;
+
+define test test-trace-method ()
+end test test-trace-method;
+
+define test test-connect-method ()
+end test test-connect-method;
+
+//---------------------------------------------------------------------
+// utilities
+
+define variable *test-host* :: <string> = "localhost";
+
+define variable *test-port* :: <integer> = 80;
+
+define variable *test-url-base-directory* :: <string> = "/http-test/";
+
+define function test-url
+ (url :: <string>) => (full-url :: <url>)
+ parse-url(concatenate("http://", *test-host*, ":", *test-port*,
+ *test-url-prefix*, url))
+end function test-url;
+
+begin
+ run-test-application(http-protocol-test-suite);
+end;
+
Added: trunk/libraries/network/http-client/http-protocol-test-suite/http-protocol-test-suite.lid
==============================================================================
--- (empty file)
+++ trunk/libraries/network/http-client/http-protocol-test-suite/http-protocol-test-suite.lid Fri May 2 12:58:04 2008
@@ -0,0 +1,3 @@
+library: http-protocol-test-suite
+files: library.dylan
+ http-protocol-test-suite.dylan
Added: trunk/libraries/network/http-client/http-protocol-test-suite/library.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/http-client/http-protocol-test-suite/library.dylan Fri May 2 12:58:04 2008
@@ -0,0 +1,14 @@
+module: dylan-user
+
+define library http-protocol-test-suite
+ use common-dylan;
+ use testworks;
+ use http-client;
+ export http-protocol-test-suite;
+end library http-protocol-test-suite;
+
+define module http-protocol-test-suite
+ use common-dylan;
+ use testworks;
+ use http-client;
+end module http-protocol-test-suite;
Added: trunk/libraries/network/http-client/library.dylan
==============================================================================
--- (empty file)
+++ trunk/libraries/network/http-client/library.dylan Fri May 2 12:58:04 2008
@@ -0,0 +1,39 @@
+Module: dylan-user
+
+define library http-client
+ use common-dylan;
+ use network,
+ import: { sockets };
+ use io,
+ import: { format,
+ format-out,
+ streams };
+ use system,
+ import: { locators };
+ use koala; // to be replaced with http-common
+
+ export http-client;
+end library http-client;
+
+define module http-client
+ use common-dylan,
+ exclude: { format-to-string };
+ use sockets,
+ exclude: { start-server };
+ use streams;
+ use format;
+ use format-out;
+ use locators;
+// use koala, // to be replaced with http-common
+// import: { };
+
+ export <http-error>,
+ http-error-message,
+ with-http-stream,
+ open-http-stream,
+ close-http-stream,
+ write-http-get,
+ read-http-response-header,
+ read-http-response-header-as,
+ simple-http-get;
+end module http-client;
Modified: trunk/libraries/network/koala/README.txt
==============================================================================
--- trunk/libraries/network/koala/README.txt (original)
+++ trunk/libraries/network/koala/README.txt Fri May 2 12:58:04 2008
@@ -1,5 +1,67 @@
README for Koala HTTP Server
-See "Getting Started" in <koala-root>/www/koala/koala.html for information
-on building and/or starting Koala.
+GETTING STARTED
+---------------
+
+Not much here yet. Best bet for learning how to develop a web
+application is to look at one of the existing examples. The
+koala-basics library is probably the best one to start with.
+
+
+
+DEVELOPMENT
+-----------
+
+Here are a few things you should be aware of if you want to contribute
+code for Koala.
+
+* Please more-or-less follow the coding conventions in the existing
+ code. That means keeping line lengths to around 90 (80 preferred),
+ using the standard indentation for IFs, etc. It should be fairly
+ obvious.
+
+* Please try to write unit tests for the code you add. I've become a
+ big fan of test-driven development. Writing the tests BEFORE you
+ write the code is even better. There are (at least) three test
+ suites:
+
+ + koala-test-suite -- for server
+ + http-client-test-suite -- for client
+ + http-protocol-test-suite -- to validate conformance to HTTP standard
+
+* If you make incompatible changes to the API, update references to
+ it. That means, at the very least, searching for uses of that API
+ in all of trunk/libraries and trying to update them.
+
+* It's a good idea to reference RFC 2616 (or other RFCs) when making
+ changes to the code related to a particular point in the RFCs.
+ Also, if you see a place in the code that doesn't conform to the
+ RFCs please take the time to make a note of it. If all the
+ references follow a standard format they'll be easier to find:
+
+ RFC 2616, 5.2
+
+ Right now (April, 2008) conformance to the standard is very poor, but
+ I (cgay) plan to start improving it.
+
+* Annotate definitions exported in the public API module (koala) with
+
+ // Exported
+
+ or
+
+ // API
+
+ above them. This just makes it less likely for someone to
+ accidentally change them incompatibly without meaning to.
+
+* Annotate brokenness that you aren't planning to fix right away with
+
+ // FIXME: ...
+
+ near the code. Put your name on the comment.
+
+* Annotate missing functionality with "// TODO: ...". Put your name
+ on the comment.
+
Modified: trunk/libraries/network/koala/config/koala-config.xml
==============================================================================
Binary files. No diff available.
Modified: trunk/libraries/network/koala/docs/rfc2616-http-1.1.txt
==============================================================================
--- trunk/libraries/network/koala/docs/rfc2616-http-1.1.txt (original)
+++ trunk/libraries/network/koala/docs/rfc2616-http-1.1.txt Fri May 2 12:58:04 2008
@@ -1,4 +1,7 @@
+[---*** cgay
+I'm adding comments to this as I go. Each will be marked like the
+above, with ---*** and the commenter's name, inside square brackets.]
@@ -1364,6 +1367,11 @@
3.6.1 Chunked Transfer Coding
+[---*** cgay
+I think this means we can have a pool of fixed-size buffers for the output
+stream and send data in chunks to any client that claims to support
+chunked xfer. Currently we buffer everything, no matter how big.]
+
The chunked encoding modifies the body of a message in order to
transfer it as a series of chunks, each with its own size indicator,
followed by an OPTIONAL trailer containing entity-header fields. This
Modified: trunk/libraries/network/koala/sources/examples/koala-basics/library.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/examples/koala-basics/library.dylan (original)
+++ trunk/libraries/network/koala/sources/examples/koala-basics/library.dylan Fri May 2 12:58:04 2008
@@ -20,7 +20,8 @@
use threads;
use common-extensions,
exclude: { format-to-string };
- use locators;
+ use locators,
+ exclude: { <http-server> }; // badly named
use format;
use streams;
use dsp;
Modified: trunk/libraries/network/koala/sources/examples/koala-basics/main.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/examples/koala-basics/main.dylan (original)
+++ trunk/libraries/network/koala/sources/examples/koala-basics/main.dylan Fri May 2 12:58:04 2008
@@ -359,8 +359,10 @@
begin
// If you don't need to add any new command-line arguments you can just
- // call koala-main directly. It requires that you pass --config <filename>
- // on the command line.
+ // call koala-main directly. It allows you to pass --config <filename>
+ // and other args on the command line. Use --help to see options.
+ // start-server can also be used directly if you want to do your own
+ // command-line parsing.
koala-main();
end;
Modified: trunk/libraries/network/koala/sources/koala-app/koala-app.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala-app/koala-app.dylan (original)
+++ trunk/libraries/network/koala/sources/koala-app/koala-app.dylan Fri May 2 12:58:04 2008
@@ -7,5 +7,5 @@
// if there's a good way to fix it.
begin
- koala-main();
+ koala-main(make(<http-server>));
end;
Modified: trunk/libraries/network/koala/sources/koala-app/library.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala-app/library.dylan (original)
+++ trunk/libraries/network/koala/sources/koala-app/library.dylan Fri May 2 12:58:04 2008
@@ -12,6 +12,6 @@
define module koala-app
use dylan;
use operating-system, import: { application-arguments };
- use koala, import: { koala-main };
+ use koala, import: { koala-main, <http-server> };
end;
Modified: trunk/libraries/network/koala/sources/koala/config.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/config.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/config.dylan Fri May 2 12:58:04 2008
@@ -5,7 +5,6 @@
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.
@@ -14,13 +13,15 @@
define constant $koala-config-dir :: <string> = "config";
define constant $koala-config-filename :: <string> = "koala-config.xml";
+define thread variable %dir = #f;
+
// Holds the current vhost while config elements are being processed.
-define thread variable %vhost = $default-virtual-host;
+define thread variable %vhost = #f;
define inline function active-vhost
() => (vhost :: <virtual-host>)
- if (%vhost == $default-virtual-host
- & ~ *fall-back-to-default-virtual-host?*)
+ if (%vhost == default-virtual-host(*server*)
+ & ~ *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. "
@@ -31,9 +32,6 @@
end
end;
-define thread variable %dir = root-directory-spec($default-virtual-host);
-
-
// Process the server config file, config.xml.
// Assume a user directory structure like:
// koala/
@@ -42,13 +40,13 @@
// 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));
+ 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));
block (return)
let handler <error> = method (c :: <error>, next-handler :: <function>)
if (*debugging-server*)
@@ -65,7 +63,10 @@
// instead of just returning #f.
let xml :: false-or(xml$<document>) = xml$parse-document(text);
if (xml)
- process-config-node(xml);
+ dynamic-bind (%vhost = default-virtual-host(*server*),
+ %dir = root-directory-spec(default-virtual-host(*server*)))
+ process-config-node(xml);
+ end;
else
log-error("Unable to parse config file!");
*abort-startup?* := #t;
@@ -100,7 +101,7 @@
// I think the XML parser's class hierarchy is broken. It seems <tag>
// should inherit from <node-mixin> so that one can descend the node
-// hierarchy seemlessly.
+// hierarchy seamlessly.
define method process-config-node (node :: xml$<tag>) => ()
end;
@@ -174,12 +175,11 @@
(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.");
- else
+ block ()
add-virtual-host(name, active-vhost());
- end
+ exception (err :: <koala-api-error>)
+ warn("Invalid <ALIAS> element. %s", err);
+ end;
else
warn("Invalid <ALIAS> element. The 'name' attribute must be specified.");
end;
@@ -224,26 +224,6 @@
end;
define method process-config-element
- (node :: xml$<element>, name == #"port")
- let attr = get-attr(node, #"value");
- if (attr)
- 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);
- else
- error("jump to the exception clause :-)");
- end;
- exception (<error>)
- warn("VHost '%s': Invalid port %=", vhost-name(active-vhost()), attr);
- end;
- else
- 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,
@@ -258,10 +238,10 @@
// 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)
+ if (%vhost == default-virtual-host(*server*))
let loc = get-attr(node, #"location");
if (loc)
- init-server-root(location: loc);
+ *server-root* := merge-locators(as(<directory-locator>, loc), *server-root*);
log-info("Server root set to %s", loc);
else
warn("Invalid <SERVER-ROOT> spec. "
Modified: trunk/libraries/network/koala/sources/koala/errors.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/errors.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/errors.dylan Fri May 2 12:58:04 2008
@@ -7,9 +7,6 @@
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-// TODO: I cannot stand the http-error-definer macro. Ditch it or fix it.
-// Also, most of the error classes should be exported.
-
// See RFC 2616, 6.1.1
define class <koala-error> (<format-string-condition>, <error>)
@@ -61,37 +58,25 @@
$application-error-code
end;
-// NOTE: It's important that condition-to-string return a string with no CRLF in it
-// since this string will be sent directly back to the client in the response line.
-define method http-error-message (e :: <error>)
- $application-error-message
-end;
-
-define method http-error-message (e :: <http-error>)
- let msg = condition-to-string(e);
- let pos = char-position($cr, msg, 0, size(msg)) | char-position($lf, msg, 0, size(msg));
- iff(pos,
- substring(msg, 0, pos),
- msg)
-end;
-
// This is for sending to the client
define method http-error-message-no-code
- (e :: <http-error>) => (msg :: false-or(<string>))
- apply(format-to-string, condition-format-string(e), condition-format-arguments(e))
+ (error :: <http-error>) => (msg :: false-or(<string>))
+ apply(format-to-string,
+ condition-format-string(error),
+ condition-format-arguments(error))
end;
define method http-error-message-no-code
- (e :: <error>) => (msg :: <string>)
+ (error :: <error>) => (msg :: <string>)
"An unhandled application error was encountered."
end method http-error-message-no-code;
// This is for logging.
define method condition-to-string
- (e :: <http-error>) => (s :: <string>)
+ (error :: <http-error>) => (s :: <string>)
format-to-string("%d %s",
- http-error-code(e),
- http-error-message-no-code(e))
+ http-error-code(error),
+ http-error-message-no-code(error))
end;
// Error codes 3xx
@@ -139,7 +124,7 @@
define http-error moved-temporarily-redirect (<http-redirect-error>)
302
"The document has moved temporarily to %s",
- loction;
+ location;
define http-error see-other-redirect (<http-redirect-error>)
303 "See Other";
@@ -159,19 +144,9 @@
400 "Bad request: %s",
message;
-define http-error invalid-url-error (<http-parse-error>)
- 400 "Invalid request url: %=",
- url;
-
-define http-error invalid-url-encoding-error (<http-parse-error>)
- 400 "Invalid digits following %% in urlencoded string";
-
define http-error bad-header-error (<http-parse-error>)
400 "Malformed syntax in message header";
-define http-error invalid-request-line-error (<http-parse-error>)
- 400 "Malformed syntax in request line";
-
// Response MUST include WWW-Authenticate header
define http-error unauthorized-error (<http-client-error>)
401 "Unauthorized";
Modified: trunk/libraries/network/koala/sources/koala/header-values.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/header-values.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/header-values.dylan Fri May 2 12:58:04 2008
@@ -337,8 +337,11 @@
let pos = token-end-position(str, bpos, epos) | epos;
unless (pos == bpos | i == 8)
v[i] := string->integer(str, bpos, pos) | substring(str, bpos, pos);
- let bpos = if (pos == epos | str[pos] == ';') epos
- else skip-whitespace(str, pos + 1, epos) end;
+ let bpos = if (pos == epos | str[pos] == ';')
+ epos
+ else
+ skip-whitespace(str, pos + 1, epos)
+ end;
if (bpos ~== epos)
loop(bpos, i + 1)
else
Modified: trunk/libraries/network/koala/sources/koala/koala-main.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/koala-main.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/koala-main.dylan Fri May 2 12:58:04 2008
@@ -5,29 +5,20 @@
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*,
+ <parameter-option-parser>,
+ description: "Port number on which to listen",
+ long-options: #("port"),
+ short-options: #("p"));
+ add-option-parser-by-type(*argument-list-parser*,
<simple-option-parser>,
description: "Display this help message",
long-options: #("help"),
@@ -37,16 +28,22 @@
description: "Enable debugging. Causes Koala to not handle "
"most errors during request handling.",
long-options: #("debug"));
-
- //init-server();
end;
begin
init-koala();
end;
+// A "main" function for web apps that want to start up Koala in the foreground
+// with a standardized command-line.
// This is defined here rather than in koala-app because wiki needs it too.
-define function koala-main ()
+//
+define function koala-main
+ (#key server :: false-or(<http-server>),
+ debug :: <boolean>,
+ port :: false-or(<integer>),
+ config-file :: false-or(<string>))
+ => ()
let parser = *argument-list-parser*;
parse-arguments(parser, application-arguments());
if (option-value-by-long-name(parser, "help")
@@ -58,9 +55,11 @@
usage: "koala [options]",
description: desc);
else
- if (option-value-by-long-name(parser, "debug"))
- *debugging-server* := #t;
- end;
- start-server(config-file: option-value-by-long-name(parser, "config"));
+ start-server(server | make(<http-server>),
+ config-file: option-value-by-long-name(parser, "config"),
+ port: string-to-integer(option-value-by-long-name(parser, "port")
+ | "80"),
+ debug: option-value-by-long-name(parser, "debug"));
end;
end function koala-main;
+
Modified: trunk/libraries/network/koala/sources/koala/library-unix.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/library-unix.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/library-unix.dylan Fri May 2 12:58:04 2008
@@ -149,8 +149,7 @@
// Basic server stuff
create
- http-server, // Get the active HTTP server object.
- ensure-server, // Get (or create) the active HTTP server object.
+ <http-server>,
start-server,
stop-server,
<responder>,
@@ -163,7 +162,6 @@
*request*, // Holds the active request, per thread.
current-request, // Returns the active request of the thread.
current-response, // Returns the active response of the thread.
- request-query-string,
request-query-values, // get the keys/vals from the current GET or POST request
request-method, // Returns #"get", #"post", etc
request-host,
@@ -275,10 +273,6 @@
request-url,
request-tail-url;
- // Debugging
- create
- print-object;
-
// Files
create
static-file-responder;
@@ -447,7 +441,9 @@
use locators,
rename: { <http-server> => <http-server-url>,
<ftp-server> => <ftp-server-url>,
- <file-server> => <file-server-url> };
+ <file-server> => <file-server-url>
+ },
+ exclude: { <url> }; // this comes from the uri library now.
use dylan-extensions,
import: { element-no-bounds-check,
element-no-bounds-check-setter,
@@ -473,7 +469,6 @@
use command-line-parser;
use uri;
use regular-expressions;
-
use dsp;
end module httpi;
Modified: trunk/libraries/network/koala/sources/koala/library.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/library.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/library.dylan Fri May 2 12:58:04 2008
@@ -149,8 +149,7 @@
// Basic server stuff
create
- http-server, // Get the active HTTP server object.
- ensure-server, // Get (or create) the active HTTP server object.
+ <http-server>,
start-server,
stop-server,
<responder>,
@@ -175,7 +174,8 @@
count-query-values,
application-error,
current-url,
- redirect-to;
+ redirect-to,
+ redirect-temporarily-to;
// Virtual hosts
create
@@ -259,6 +259,7 @@
create
moved-permanently-redirect,
+ moved-temporarily-redirect,
see-other-redirect,
unauthorized-error;
@@ -439,7 +440,9 @@
use locators,
rename: { <http-server> => <http-server-url>,
<ftp-server> => <ftp-server-url>,
- <file-server> => <file-server-url> };
+ <file-server> => <file-server-url>
+ },
+ exclude: { <url> }; // this comes from the uri library now.
use dylan-extensions,
import: { element-no-bounds-check,
element-no-bounds-check-setter,
@@ -465,7 +468,6 @@
use command-line-parser;
use uri;
use regular-expressions;
-
use dsp;
end module httpi;
Modified: trunk/libraries/network/koala/sources/koala/server.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/server.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/server.dylan Fri May 2 12:58:04 2008
@@ -12,6 +12,7 @@
// This may be set true by config file loading code, in which case
// start-server will be a no-op.
+// todo -- Just raise an exception instead (or at least make this a thread variable).
define variable *abort-startup?* :: <boolean> = #f;
define constant $server-header-value = concatenate($server-name, "/", $server-version);
@@ -64,19 +65,53 @@
slot connections-accepted :: <integer> = 0; // Connections accepted
constant slot user-agent-stats :: <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>,
+ required-init-keyword: #"default-virtual-host";
+
end class <server>;
define sealed method make
- (c == <server>, #rest keys, #key) => (server :: <server>)
+ (class == <server>, #rest keys, #key) => (server :: <server>)
let lock = make(<lock>);
let listeners-notification = make(<notification>, lock: lock);
let clients-notification = make(<notification>, lock: lock);
- apply(next-method, c,
+ let stdout-log = make(<stream-log-target>, stream: *standard-output*);
+ let vhost = make(<virtual-host>,
+ name: "default",
+ activity-log: stdout-log,
+ debug-log: stdout-log,
+ error-log: make(<stream-log-target>, stream: *standard-error*));
+ apply(next-method, class,
lock: lock,
listeners-notification: listeners-notification,
clients-notification: clients-notification,
+ default-virtual-host: vhost,
keys)
-end make;
+end method make;
+
+// API
+// The user instantiates this class directly, passing configuration options
+// as init args. Using an alias for now instead of renaming <server>. We'll
+// see how things progress.
+//
+define constant <http-server> = <server>;
+
+// API
+define method initialize
+ (server :: <http-server>,
+ #rest keys,
+ #key document-root: doc-root)
+ apply(next-method, remove-keys(keys, #"document-root"));
+ let vhost :: <virtual-host> = default-virtual-host(server);
+ if (doc-root)
+ document-root(vhost) := as(<directory-locator>, doc-root);
+ end;
+end;
// Keep some stats on user-agents
define method note-user-agent
@@ -176,6 +211,7 @@
end;
*/
+// todo -- make thread safe
define variable *sockets-started?* :: <boolean> = #f;
define function ensure-sockets-started ()
@@ -186,31 +222,23 @@
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 thread variable *server* :: false-or(<server>) = #f;
+// make thread variable
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 :: <http-server>,
+ #key listeners :: <integer> = 1,
+ request-class :: subclass(<basic-request>) = *default-request-class*,
+ config-file :: false-or(<string>))
server.max-listeners := listeners;
server.request-class := request-class;
- configure-server(config-file);
+ *server* := server;
+ if (config-file)
+ configure-server(config-file);
+ end;
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*);
@@ -224,49 +252,45 @@
// This is what client libraries call to start the server.
//
define function start-server
- (#key config-file :: false-or(<string>))
+ (server :: <http-server>,
+ #key config-file :: false-or(<string>),
+ port :: false-or(<integer>),
+ background :: <boolean> = #f,
+ debug :: <boolean> = #f)
=> (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);
+ *debugging-server* := debug;
+ init-server(server, config-file: config-file);
if (*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))
- end;
- if (*fall-back-to-default-virtual-host?*)
- ports := add!(ports, vhost-port($default-virtual-host));
- 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
+ let listen-ip = vhost-ip(default-virtual-host(server));
+ local method start-server-internal ()
+ http-server-top-level(server, listen-ip, port | 80);
+ end;
+ if (background)
+ make(<thread>, function: start-server-internal, name: "HTTP Server");
else
- // temporary code...
- let port = ports[0];
- let ip = vhost-ip($default-virtual-host);
- while (start-http-listener(*server*, port, ip))
- *server-running?* := #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
+ start-server-internal()
+ end;
+ #t
end if
end function start-server;
+define function http-server-top-level
+ (server :: <http-server>, listen-ip :: <string>, listen-port :: <integer>)
+ dynamic-bind (*server* = server)
+ while (start-http-listener(*server*, listen-port, listen-ip))
+ *server-running?* := #t;
+ end;
+ // Apparently when the main thread dies in an Open 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;
+ end;
+end function http-server-top-level;
+
define function join-listeners
(server :: <server>)
// Don't use join-thread, because no timeouts, so could hang.
@@ -283,18 +307,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);
+// API
+define function stop-server
+ (server :: <http-server>, #key abort)
+ abort-listeners(server);
+ when (~abort)
+ join-clients(server);
end;
-end;
+ abort-clients(server);
+end function stop-server;
define function abort-listeners (server :: <server>)
iterate next ()
@@ -349,8 +370,9 @@
end;
end join-clients;
-define function start-http-listener (server :: <server>, port :: <integer>, ip :: <string>)
- => (started? :: <boolean>)
+define function start-http-listener
+ (server :: <server>, port :: <integer>, ip :: <string>)
+ => (started? :: <boolean>)
let server-lock = server.server-lock;
let listener = #f;
local method run-listener-top-level ()
@@ -373,7 +395,8 @@
log-debug("Creating a new listener thread.");
let socket = make(<server-socket>, host: ip, port: port);
let thread = make(<thread>,
- name: format-to-string("HTTP Listener #%s/%d", *next-listener-id*, port),
+ 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>,
@@ -532,6 +555,29 @@
define variable *default-request-class* :: subclass(<basic-request>) = <request>;
define thread variable *request* :: false-or(<request>) = #f;
+
+define method virtual-host
+ (request :: <request>) => (vhost :: false-or(<virtual-host>))
+ let host-spec = request-host(request);
+ if (host-spec)
+ let colon = char-position(':', host-spec, 0, size(host-spec));
+ let host = iff(colon, substring(host-spec, 0, colon), host-spec);
+ let vhost = virtual-host(host)
+ | (*fall-back-to-default-virtual-host?*
+ & default-virtual-host(*server*));
+ if (vhost)
+ vhost
+ else
+ // todo -- see if the spec says what error to return here.
+ resource-not-found-error(url: request.request-url);
+ end;
+ elseif (*fall-back-to-default-virtual-host?*)
+ default-virtual-host(*server*)
+ else
+ resource-not-found-error(url: request.request-url);
+ end
+end;
+
define thread variable *response* :: false-or(<response>) = #f;
define inline function current-request () => (request :: <request>) *request* end;
@@ -540,7 +586,8 @@
// Called (in a new thread) each time an HTTP request is received.
define function handler-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>
@@ -602,11 +649,18 @@
let socket = request.request-socket;
let server = request.request-server;
let (buffer, len) = read-request-line(socket);
- when (empty-line?(buffer, len))
- // RFC 2616, 4.1 - Servers SHOULD ignore an empty line if received before any headers.
+
+ // RFC 2616, 4.1 - "Servers SHOULD ignore an empty line(s) received where a
+ // Request-Line is expected." Clearly you have to give up at some point so
+ // we arbitrarily allow 5 blank lines.
+ let line-count :: <integer> = 0;
+ while (empty-line?(buffer, len))
+ if (line-count > 5)
+ bad-request(message: "No Request-Line received.");
+ end;
pset (buffer, len) read-request-line(socket) end;
end;
- log-info("%s", substring(buffer, 0, len));
+
read-request-first-line(request, buffer);
unless (request.request-version == #"http/0.9")
request.request-headers
@@ -622,24 +676,25 @@
end select;
end method read-request;
-
-// Read first line of the HTTP request. RFC 2068 Section 5.1
+// FIXME: It seems like a bad idea to me to use a regex here as it will allocate
+// a lot and is probably much slower than the direct approach. --cgay
define constant $request-line-regex :: <regex>
= compile-regex("^([!#$%&'\\*\\+-\\./0-9A-Z^_`a-z\\|~]+) "
"(\\S+) "
"(HTTP/\\d+\\.\\d+)");
+// Read the Request-Line. RFC 2616 Section 5.1
+//
define function read-request-first-line
(request :: <request>, buffer :: <string>)
=> ()
- let (entire-match, http-method, url, http-version) =
- regex-search-strings($request-line-regex, buffer);
- log-debug("%= %= %=", http-method, url, http-version);
+ let (entire-match, http-method, url, http-version)
+ = regex-search-strings($request-line-regex, buffer);
if (entire-match)
request.request-method := as(<symbol>, http-method);
let url = parse-url(url);
- // See http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.2
- // Absolute URLs in the request line take precedence over Host header.
+ // RFC 2616, 5.2 -- absolute URLs in the request line take precedence
+ // over Host header.
if (absolute?(url))
request.request-host := url.uri-host;
end if;
@@ -656,7 +711,8 @@
end for;
request.request-version := extract-request-version(http-version);
else
- invalid-request-line-error();
+ // Using regex means this error message has to be vague.
+ bad-request(message: "Invalid request line");
end if;
end function read-request-first-line;
@@ -829,16 +885,14 @@
end;
bind (host = get-header(request, "Host"))
if (~host & request.request-version == #"HTTP/1.1")
- // HTTP/1.1 requests MUST include a Host header.
- // http://www.w3.org/Protocols/rfc2616/rfc2616-sec19.html#sec19.6.1.1
+ // RFC 2616, 19.6.1.1 -- HTTP/1.1 requests MUST include a Host header.
bad-request(message: "HTTP/1.1 requests must include a Host header.");
end;
- // If request host is already set then there was an absolute URL in the request
- // line, which takes precedence, so ignore Host header here.
- // See http://www.w3.org/Protocols/rfc2616/rfc2616-sec5.html#sec5.2
+ // RFC 2616, 5.2 -- If request host is already set then there was an absolute
+ // URL in the request line, which takes precedence, so ignore Host header here.
if (host & ~request.request-host)
request.request-host := host;
- log-debug("Request host is '%s'", request.request-host);
+ log-debug("Request host set from Host header to: %s", request.request-host);
end;
end;
bind (agent = request-header-value(request, #"user-agent"))
@@ -888,7 +942,6 @@
resource-not-found-error(url: url);
end if;
else
- log-debug("Maybe serve static file");
// generates 404 if not found
maybe-serve-static-file();
end if;
@@ -1068,3 +1121,4 @@
f(key, val);
end;
end;
+
Modified: trunk/libraries/network/koala/sources/koala/static-files.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/static-files.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/static-files.dylan Fri May 2 12:58:04 2008
@@ -45,9 +45,9 @@
define method maybe-serve-static-file ()
let request = current-request();
let response = current-response();
- let url = build-uri(request.request-url);
- let document :: false-or(<physical-locator>)
- = static-file-locator-from-url(url);
+ // Just use the path, not the host, query, or fragment.
+ let url = build-path(request.request-url);
+ let document :: false-or(<physical-locator>) = static-file-locator-from-url(url);
log-debug("Requested document is %s", document);
if (~document)
log-info("%s not found", url);
@@ -103,8 +103,8 @@
end if;
end method maybe-serve-static-file;
-// @returns the appropriate locator for the given URL, or #f if the URL is
-// invalid (for example it doesn't name an existing file below the document root).
+// Returns the appropriate locator for the given URL, or #f if the URL doesn't
+// name an existing file below the document root.
// If the URL names a directory this checks for an appropriate default document
// such as index.html and returns a locator for that, if found.
//
Modified: trunk/libraries/network/koala/sources/koala/string-utils.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/string-utils.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/string-utils.dylan Fri May 2 12:58:04 2008
@@ -1,5 +1,7 @@
Module: utilities
-Synopsis: String utilities
+Synopsis: Low-level string utilities for HTTP request parsing etc.
+ These should be as fast as possible. In general we're dealing
+ with the US ASCII charset for HTTP so <byte-string> suffices.
Author: Gail Zacharias, Carl Gay
Copyright: Copyright (c) 2001 Carl L. Gay. All rights reserved.
Original Code is Copyright (c) 2001 Functional Objects, Inc. All rights reserved.
@@ -101,21 +103,31 @@
end;
end;
+// RFC 2616, 2.2
+define constant $token-character-map
+ = begin
+ let vec = make(<vector>, size: 128, fill: #t);
+ let separator-chars = "()<>@,;:\\\"/[]?={} \t";
+ for (char in separator-chars)
+ vec[as(<integer>, char)] := #f;
+ end;
+ // US ASCII control characters...
+ for (code from 0 to 32)
+ vec[code] := #f;
+ end;
+ vec[127] := #f; // DEL
+ vec
+ end;
+
+define inline function token-char?
+ (char :: <byte-character>) => (token-char? :: <boolean>)
+ let code :: <integer> = as(<integer>, char);
+ code <= 127 & $token-character-map[code]
+end;
-// Ugh. should look up in a table...
-define inline function non-token-char? (ch :: <byte-character>)
- let c = as(<integer>, ch);
- c <= 32 | c >= 127 |
- c == as(<integer>, '"') |
- c == as(<integer>, '(') |
- c == as(<integer>, ')') |
- c == as(<integer>, ',') |
- c == as(<integer>, '/') |
- c == as(<integer>, '/') |
- c == as(<integer>, '{') |
- c == as(<integer>, '}') |
- (as(<integer>, ':') <= c & c <= as(<integer>, '@')) | // ":;<=>?@"
- (as(<integer>, '[') <= c & c <= as(<integer>, ']')) // "[\]"
+define inline function non-token-char?
+ (char :: <byte-character>) => (non-token-char? :: <boolean>)
+ ~token-char?(char)
end;
define function token-end-position (buf :: <byte-string>,
Modified: trunk/libraries/network/koala/sources/koala/urls.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/urls.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/urls.dylan Fri May 2 12:58:04 2008
@@ -28,7 +28,7 @@
let headers = current-response().response-headers;
add-header(headers, "Location", url);
moved-temporarily-redirect(headers: headers);
-end method redirect-to;
+end method redirect-temporarily-to;
define method redirect-temporarily-to (url :: <url>)
redirect-to(build-uri(url));
Modified: trunk/libraries/network/koala/sources/koala/variables.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/variables.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/variables.dylan Fri May 2 12:58:04 2008
@@ -18,23 +18,8 @@
// 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;
-
+define variable *server-root* :: <directory-locator>
+ = parent-directory(locator-directory(as(<file-locator>, application-filename())));
// TODO: The follow 3 should probably be per vhost.
Modified: trunk/libraries/network/koala/sources/koala/vhost.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/koala/vhost.dylan (original)
+++ trunk/libraries/network/koala/sources/koala/vhost.dylan Fri May 2 12:58:04 2008
@@ -5,7 +5,6 @@
License: Functional Objects Library Public License Version 1.0
Warranty: Distributed WITHOUT WARRANTY OF ANY KIND
-
// 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)
@@ -98,13 +97,6 @@
slot document-root :: <directory-locator>;
slot dsp-root :: <directory-locator>;
- // TODO: no need for this here. Even though ports can be specified inside
- // the virtual host definition in the config file, we just need a
- // list of virtual hosts per port. Start up one listener per port
- // and serve requests only for the vhosts that are registered on that
- // port.
- slot vhost-port :: <integer> = 80;
-
// I'd like to rename this to vhost-bind-address or maybe vhost-listen-ip-address,
// and probably use a constant for INADDR_ANY. --cgay
slot vhost-ip :: <string> = "0.0.0.0";
@@ -168,7 +160,7 @@
constant slot auto-register-map :: <table> = make(<string-table>);
// Log targets. If these are #f then the default virtual host's
- // log target is used. They are never #f in $default-virtual-host.
+ // log target is used. They are never #f in the default virtual host.
slot %activity-log-target :: false-or(<log-target>) = #f,
init-keyword: #"activity-log";
slot %error-log-target :: false-or(<log-target>) = #f,
@@ -191,8 +183,6 @@
define method initialize
(vhost :: <virtual-host>, #key name, #all-keys)
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.
vhost.document-root := subdirectory-locator(*server-root*, name);
vhost.dsp-root := subdirectory-locator(*server-root*, name);
@@ -202,17 +192,23 @@
define method activity-log-target
(vhost :: <virtual-host>) => (target :: <log-target>)
- vhost.%activity-log-target | $default-virtual-host.%activity-log-target
+ vhost.%activity-log-target
+ | (*server* & default-virtual-host(*server*).%activity-log-target)
+ | *temp-log-target*
end;
define method debug-log-target
(vhost :: <virtual-host>) => (target :: <log-target>)
- vhost.%debug-log-target | $default-virtual-host.%debug-log-target
+ vhost.%debug-log-target
+ | (*server* & default-virtual-host(*server*).%debug-log-target)
+ | *temp-log-target*
end;
define method error-log-target
(vhost :: <virtual-host>) => (target :: <log-target>)
- vhost.%error-log-target | $default-virtual-host.%error-log-target
+ vhost.%error-log-target
+ | (*server* & default-virtual-host(*server*).%error-log-target)
+ | *temp-log-target*
end;
define method add-directory-spec
@@ -224,20 +220,7 @@
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;
-
+// todo: move into <server>
// 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
@@ -245,72 +228,32 @@
//
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?*).
+// Maps host names to virtual hosts.
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 thread variable *virtual-host* :: <virtual-host>
+ = make(<virtual-host>, name: "temporary"); // this value will be replaced.
define method add-virtual-host
(name :: <string>, vhost :: <virtual-host>)
- $virtual-hosts[name] := vhost;
+ let low-name = as-lowercase(name);
+ if (element($virtual-hosts, low-name, default: #f))
+ signal(make(<koala-api-error>,
+ format-string: "Virtual host (%s) already exists.",
+ format-arguments: list(low-name)));
+ else
+ $virtual-hosts[low-name] := vhost;
+ end;
end;
-define method virtual-host
- (name :: <string>) => (vhost :: false-or(<virtual-host>))
- element($virtual-hosts, name, default: #f)
-end;
+define generic virtual-host
+ (thing :: <object>) => (vhost :: false-or(<virtual-host>));
define method virtual-host
- (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",
- host-spec));
- end;
- if (host-spec)
- let colon = char-position(':', host-spec, 0, size(host-spec));
- let host = iff(colon, substring(host-spec, 0, colon), host-spec);
- let port = colon &
- block ()
- string-to-integer(host-spec, start: colon + 1)
- exception (ex :: <error>)
- log-debug("error parsing port in host spec");
- die();
- end;
- let vhost = virtual-host(host) | (*fall-back-to-default-virtual-host?*
- & $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;
- else
- (*fall-back-to-default-virtual-host?* & $default-virtual-host)
- | die()
- end
+ (name :: <string>) => (vhost :: false-or(<virtual-host>))
+ element($virtual-hosts, as-lowercase(name), default: #f)
end;
-define method virtual-host
- (port :: <integer>)
- => (vhost :: false-or(<virtual-host>))
- block (return)
- for (vhost :: <virtual-host> keyed-by name in $virtual-hosts)
- if (vhost-port(vhost) == port)
- return(vhost)
- end if;
- end for;
- end
-end method virtual-host;
-
define method directory-spec-matching
(vhost :: <virtual-host>, url :: <string>)
iterate loop (specs :: <list> = directory-specs(vhost))
Modified: trunk/libraries/network/web-framework/changes.dylan
==============================================================================
--- trunk/libraries/network/web-framework/changes.dylan (original)
+++ trunk/libraries/network/web-framework/changes.dylan Fri May 2 12:58:04 2008
@@ -113,19 +113,19 @@
end;
define class <raw-content> (<content>)
- inherited slot type :: <string> = "raw";
+ inherited slot type = "raw";
end;
define class <textile-content> (<content>)
- inherited slot type :: <string> = "textile";
+ inherited slot type = "textile";
end;
define class <markup-content> (<content>)
- inherited slot type :: <string> = "markup";
+ inherited slot type = "markup";
end;
define class <xhtml-content> (<content>)
- inherited slot type :: <string> = "xhtml";
+ inherited slot type = "xhtml";
end;
/*
Modified: trunk/libraries/network/web-framework/library.dylan
==============================================================================
--- trunk/libraries/network/web-framework/library.dylan (original)
+++ trunk/libraries/network/web-framework/library.dylan Fri May 2 12:58:04 2008
@@ -49,7 +49,7 @@
setup,
restore,
restore-newest,
- version,
+ //version,
storage-type,
key;
end;
@@ -101,7 +101,7 @@
use web-framework-macro;
//user stuff
- export <access-level>;
+ //export <access-level>;
export <user>,
username,
@@ -116,8 +116,8 @@
find-user,
authenticate,
login,
- logout,
- valid-user?;
+ logout;
+ //valid-user?;
end;
define module change
@@ -248,7 +248,8 @@
end;
define module web-framework
- use common-dylan;
+ use common-dylan,
+ exclude: { format-to-string };
use object-table;
use simple-xml;
use koala;
Modified: trunk/libraries/network/wiki/admin.dylan
==============================================================================
--- trunk/libraries/network/wiki/admin.dylan (original)
+++ trunk/libraries/network/wiki/admin.dylan Fri May 2 12:58:04 2008
@@ -1,8 +1,14 @@
module: wiki
+// temp
+define method current-user
+ ()
+ authenticated-user()
+end;
+
define method respond-to-post
- (page :: <admin-page>, request :: <request>, response :: <response>)
- if (logged-in?(request))
+ (page :: <admin-page>)
+ if (logged-in?(current-request()))
let action = as(<symbol>, get-query-value("action"));
if (any?(method(x) action = x end, current-user().access))
select (action)
@@ -14,7 +20,7 @@
end;
end;
end;
- respond-to-get(page, request, response);
+ respond-to-get(page);
end;
define method remove-user (username)
@@ -78,7 +84,7 @@
end;
define body tag privilege in wiki
- (page :: <wiki-page>, response :: <response>, do-body :: <function>)
+ (page :: <wiki-page>, do-body :: <function>)
(value :: <string>)
let user = *user* | current-user();
if (user & any?(method(x) x = as(<symbol>, value) end, user.access))
@@ -88,7 +94,7 @@
define named-method privilege? in wiki
- (page :: <wiki-page>, request :: <request>)
+ (page :: <wiki-page>, request :: <request>)
*user* & *privilege* & any?(method(x) x = *privilege* end, *user*.access)
end;
@@ -97,7 +103,7 @@
define thread variable *privilege* = #f;
define body tag show-privileges in wiki
- (page :: <wiki-page>, response :: <response>, do-body :: <function>)
+ (page :: <wiki-page>, do-body :: <function>)
()
for (privilege in $privileges)
dynamic-bind(*privilege* = privilege)
@@ -109,15 +115,15 @@
define thread variable *user* = #f;
define tag show-privilege in wiki
- (page :: <wiki-page>, response :: <response>)
- ()
- write(output-stream(response), as(<string>, *privilege*));
+ (page :: <wiki-page>)
+ ()
+ output(as(<string>, *privilege*));
end;
define body tag show-users in wiki
- (page :: <wiki-page>, response :: <response>, do-body :: <function>)
- ()
+ (page :: <wiki-page>, do-body :: <function>)
+ ()
for (user in sort(key-sequence(storage(<user>))))
dynamic-bind(*user* = storage(<user>)[user])
do-body()
@@ -126,14 +132,14 @@
end;
define tag show-user in wiki
- (page :: <wiki-page>, response :: <response>)
- ()
- write(output-stream(response), *user*.username);
+ (page :: <wiki-page>)
+ ()
+ output(*user*.username);
end;
define body tag show-recent-changes in wiki
- (page :: <wiki-page>, response :: <response>, do-body :: <function>)
- (count :: <string>)
+ (page :: <wiki-page>, do-body :: <function>)
+ (count :: <string>)
let count = string-to-integer(count);
let done = make(<list>);
block(ret)
Modified: trunk/libraries/network/wiki/classes.dylan
==============================================================================
--- trunk/libraries/network/wiki/classes.dylan (original)
+++ trunk/libraries/network/wiki/classes.dylan Fri May 2 12:58:04 2008
@@ -87,7 +87,7 @@
content: content,
page-version: version,
wiki-page-content: page,
- comment: comment);
+ comment: comment);
with-storage (pages = <wiki-page-content>)
add!(page.revisions, revision);
end;
Modified: trunk/libraries/network/wiki/library.dylan
==============================================================================
--- trunk/libraries/network/wiki/library.dylan (original)
+++ trunk/libraries/network/wiki/library.dylan Fri May 2 12:58:04 2008
@@ -28,7 +28,8 @@
define module wiki
use common-dylan,
exclude: { format-to-string };
- use locators;
+ use locators,
+ exclude: { <http-server> }; // badly named
use streams;
use format;
use file-system;
Modified: trunk/libraries/network/wiki/parser.dylan
==============================================================================
--- trunk/libraries/network/wiki/parser.dylan (original)
+++ trunk/libraries/network/wiki/parser.dylan Fri May 2 12:58:04 2008
@@ -207,7 +207,7 @@
let lines = split(copy-sequence(markup,
start: start,
end: list-end | markup.size),
- separator: "\n", trim?: #t);
+ '\n' /*, trim?: #t */);
// write(stream, "<p>\n");
let depth :: <integer> = 0;
let regex2 = format-to-string("^\\s*([%s]+)", bullet-char);
Modified: trunk/libraries/network/wiki/wiki.dylan
==============================================================================
--- trunk/libraries/network/wiki/wiki.dylan (original)
+++ trunk/libraries/network/wiki/wiki.dylan Fri May 2 12:58:04 2008
@@ -57,18 +57,15 @@
end;
-define page view-page (<wiki-page>)
- (url: "/wiki/view.dsp",
- source: "wiki/view.dsp",
- alias: #("/wiki/", "/"))
-end;
+define class <view-page> (<wiki-page>) end;
+define variable *view-page* = make(<view-page>, source: "wiki/view.dsp");
define method page-editable? (page :: <view-page>) => (editable? :: <boolean>)
#t
end;
define method respond-to-get
- (page :: <view-page>, request :: <request>, response :: <response>)
+ (page :: <view-page>)
dynamic-bind (*title* = get-query-value("title") | *default-title*,
*version* = ignore-errors(string-to-integer(get-query-value("v"))),
*content* = page-content(*title*, version: *version*) | "(no content)")
@@ -76,13 +73,11 @@
end;
end;
-define page edit-page (<wiki-page>)
- (url: "/wiki/edit.dsp",
- source: "wiki/edit.dsp")
-end;
+define class <edit-page> (<wiki-page>) end;
+define variable *edit-page* = make(<edit-page>, source: "wiki/edit.dsp");
define method respond-to-get
- (page :: <edit-page>, request :: <request>, response :: <response>)
+ (page :: <edit-page>)
dynamic-bind (*title* = get-query-value("title"),
*content* = if (*title* & find-page(*title*))
latest-text(find-page(*title*));
@@ -99,50 +94,54 @@
*title* = "new"
end;
+// temp
+define method logged-in?
+ (request :: <request>)
+ authenticated-user() ~= #f
+end;
+
define method respond-to-post
- (page :: <edit-page>, request :: <request>, response :: <response>)
+ (page :: <edit-page>)
if (get-query-value("preview"))
- respond-to-get(*preview-page*, request, response)
+ respond-to-get(*preview-page*)
else
let title = trim(get-query-value("title") | "");
let content = get-query-value("page-content") | "";
- if (~ logged-in?(request))
+ if (~ logged-in?(current-request()))
note-form-error("You must be logged in to edit a page.");
// redisplay edit page.
dynamic-bind (*title* = title,
*content* = content)
- respond-to-get(page, request, response);
+ respond-to-get(page);
end;
elseif (title = "")
note-form-error("You must supply a valid page title.", field: "title");
// redisplay edit page.
dynamic-bind (*title* = title,
*content* = content)
- respond-to-get(page, request, response);
+ respond-to-get(page);
end;
else
save-page(title, content, comment: get-query-value("comment"));
// Show the page after editing
- respond-to-get(*view-page*, request, response);
+ respond-to-get(*view-page*);
end;
end;
end;
-define page preview-page (<wiki-page>)
- (url: "/wiki/preview.dsp",
- source: "wiki/preview.dsp")
-end;
+define class <preview-page> (<wiki-page>) end;
+define variable *preview-page* = make(<preview-page>, source: "wiki/preview.dsp");
define thread variable *comment* = #f;
define tag show-comment in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
()
- write(output-stream(response), *comment*);
+ output(*comment*);
end;
define method respond-to-get
- (page :: <preview-page>, request :: <request>, response :: <response>)
+ (page :: <preview-page>)
dynamic-bind (*title* = get-query-value("title") | "",
*content* = get-query-value("page-content") | "",
*comment* = get-query-value("comment") | "")
@@ -150,15 +149,12 @@
end;
end;
-define page login-page (<wiki-page>)
- (url: "/wiki/login.dsp",
- source: "wiki/login.dsp")
- keyword page-title:, init-value: "Login";
-end;
+define class <login-page> (<wiki-page>) end;
+define variable *login-page* = make(<login-page>,
+ source: "wiki/login.dsp",
+ title: "Login");
-define method respond-to-post (page :: <login-page>,
- request :: <request>,
- response :: <response>)
+define method respond-to-post (page :: <login-page>)
let username = get-query-value("username");
let password = get-query-value("password");
let username-supplied? = username & username ~= "";
@@ -181,10 +177,10 @@
end if;
end if;
- if (login(request, username, password))
+ if (login(current-request(), username, password))
let referer = get-query-value("referer");
if (referer & referer ~= "")
- let headers = response.response-headers;
+ let headers = response-headers(current-response());
add-header(headers, "Location", referer);
see-other-redirect(headers: headers);
end if;
@@ -197,33 +193,23 @@
next-method(); // process the DSP template
end;
-define page logout-page (<wiki-page>)
- (url: "/wiki/logout.dsp",
- source: "wiki/logout.dsp")
-end;
+define class <logout-page> (<wiki-page>) end;
+define variable *logout-page* = make(<logout-page>, source: "wiki/logout.dsp");
-define method respond-to-get (page :: <logout-page>,
- request :: <request>,
- response :: <response>)
- clear-session(request);
+define method respond-to-get (page :: <logout-page>)
+ clear-session(current-request());
next-method(); // Must call this if you want the DSP template to be processed.
end;
-define page index-page (<wiki-page>)
- (url: "/wiki/index.dsp",
- source: "wiki/index.dsp")
-end;
+define class <index-page> (<wiki-page>) end;
+define variable *index-page* = make(<index-page>, source: "wiki/index.dsp");
-define page search-page (<wiki-page>)
- (url: "/wiki/search.dsp",
- source: "wiki/search.dsp")
-end;
+define class <search-page> (<wiki-page>) end;
+define variable *search-page* = make(<search-page>, source: "wiki/search.dsp");
-define page backlink-page (<wiki-page>)
- (url: "/wiki/backlink.dsp",
- source: "wiki/backlink.dsp")
-end;
+define class <backlink-page> (<wiki-page>) end;
+define variable *backlink-page* = make(<backlink-page>, source: "wiki/backlink.dsp");
define thread variable *search-results* = #();
define thread variable *search-result* = #f;
@@ -240,11 +226,11 @@
define named-method admin? in wiki
(page :: <wiki-page>, request :: <request>)
- logged-in?(request) & current-user().access <= 23;
+ logged-in?(request) & authenticated-user().access <= 23;
end;
define method respond-to-get
- (page :: <search-page>, request :: <request>, response :: <response>)
+ (page :: <search-page>)
let search-string = trim(get-query-value("search-terms") | "");
dynamic-bind (*title* = concatenate("Search Results for "", search-string, """))
if (search-string = "")
@@ -357,27 +343,25 @@
end;
define tag sr-title in wiki
- (page :: <search-page>, response :: <response>)
+ (page :: <search-page>)
()
- write(output-stream(response), search-result-title(current-search-result()));
+ output(search-result-title(current-search-result()));
end;
define tag sr-version in wiki
- (page :: <search-page>, response :: <response>)
+ (page :: <search-page>)
()
- write(output-stream(response),
- integer-to-string(search-result-version(current-search-result())));
+ output(integer-to-string(search-result-version(current-search-result())));
end;
define tag sr-summary in wiki
- (page :: <search-page>, response :: <response>)
+ (page :: <search-page>)
()
- write(output-stream(response),
- search-result-summary(current-search-result()));
+ output(search-result-summary(current-search-result()));
end;
define body tag do-versions in wiki
- (page :: <search-page>, response :: <response>, do-body :: <function>)
+ (page :: <search-page>, do-body :: <function>)
()
for (sr in copy-sequence(current-row(), start: 1))
dynamic-bind (*search-result* = sr)
@@ -389,11 +373,10 @@
// Show the page title. If v is true, show the version number if it's not
// the newest version of the page.
define tag show-title in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
(v :: <boolean>, for-url :: <boolean>)
- let out = output-stream(response);
let title = *title* | page-title(page) | "(no title)";
- write(out, title);
+ output(title);
if (*title* & v)
let wiki-page = find-page(*title*);
if (wiki-page)
@@ -401,21 +384,20 @@
let newest = page-version(last(wiki-page.revisions));
log-debug("newest = %=, *version* = %=", newest, *version*);
if (*version* & *version* < newest)
- format(out, for-url & "&v=%s" | " (version %s)", *version*);
+ output(for-url & "&v=%s" | " (version %s)", *version*);
end;
end;
end;
end;
define tag show-content in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
(format :: <string> = "raw")
- write(output-stream(response),
- page-content(*title*, version: *version*, format: as(<symbol>, format)));
+ output(page-content(*title*, version: *version*, format: as(<symbol>, format)));
end;
define body tag show-revisions in wiki
- (page :: <wiki-page>, response :: <response>, do-body :: <function>)
+ (page :: <wiki-page>, do-body :: <function>)
(count :: <string>)
show-revisions-aux(page, do-body, string-to-integer(count));
end;
@@ -437,14 +419,14 @@
end;
define method respond-to-get
- (page :: <backlink-page>, request :: <request>, response :: <response>)
+ (page :: <backlink-page>)
dynamic-bind (*title* = get-query-value("title") | *default-title*)
next-method(); // process the DSP template
end;
end;
define body tag show-backlink in wiki
- (page :: <backlink-page>, response :: <response>, do-body :: <function>)
+ (page :: <backlink-page>, do-body :: <function>)
()
for (backlink in find-backlinks(*title*))
dynamic-bind (*title* = backlink.page-title)
@@ -454,22 +436,22 @@
end;
define tag version in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
()
- write(output-stream(response), integer-to-string(*version*));
+ output(integer-to-string(*version*));
end;
define tag username in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
()
- let user = current-user();
+ let user = authenticated-user();
if (user)
- write(output-stream(response), user.username);
+ output(user.username);
end;
end;
define body tag show-index in wiki
- (page :: <wiki-page>, response :: <response>, do-body :: <function>)
+ (page :: <wiki-page>, do-body :: <function>)
()
for (key in sort(key-sequence(storage(<wiki-page-content>))))
dynamic-bind(*title* = key)
@@ -478,20 +460,17 @@
end;
end;
-define page recent-changes-page (<wiki-page>)
- (url: "/wiki/recent.dsp",
- source: "wiki/recent.dsp")
-end;
+define class <recent-changes-page> (<wiki-page>) end;
+define variable *recent-changes-page*
+ = make(<recent-changes-page>, source: "wiki/recent.dsp");
-define page diff-page (<wiki-page>)
- (url: "/wiki/diff.dsp",
- source: "wiki/diff.dsp")
-end;
+define class <diff-page> (<wiki-page>) end;
+define variable *diff-page* = make(<diff-page>, source: "wiki/diff.dsp");
define thread variable *other-version* = #f;
define method respond-to-get
- (page :: <diff-page>, request :: <request>, response :: <response>)
+ (page :: <diff-page>)
dynamic-bind (*title* = get-query-value("title"),
*version* = ignore-errors(string-to-integer(get-query-value("version"))),
*other-version* = ignore-errors(string-to-integer(get-query-value("otherversion"))) | *version* - 1)
@@ -520,29 +499,39 @@
end;
define tag show-diff in wiki
- (page :: <diff-page>, response :: <response>)
+ (page :: <diff-page>)
()
let page = *title* & find-page(*title*);
let version = *version* & *version* - 1;
let otherversion = *other-version* & *other-version* - 1;
//this needs to be refactored
- if (version & otherversion & page & version < page.revisions.size & otherversion < page.revisions.size & otherversion >= -1)
- let target = split(page.revisions[version].content, separator: "\n");
- let source = if (otherversion = -1) #() else split(page.revisions[otherversion].content, separator: "\n") end;
- print-diffs(output-stream(response), sequence-diff(source, target), source, target);
+ if (version
+ & otherversion
+ & page
+ & version < page.revisions.size
+ & otherversion < page.revisions.size
+ & otherversion >= -1)
+ let target = split(page.revisions[version].content, '\n');
+ let source = if (otherversion = -1)
+ #()
+ else
+ split(page.revisions[otherversion].content, '\n')
+ end;
+ print-diffs(output-stream(current-response()), sequence-diff(source, target),
+ source, target);
end;
end;
define tag otherversion in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
()
- write(output-stream(response), integer-to-string(*other-version*));
+ output(integer-to-string(*other-version*));
end;
define thread variable *change* = #f;
define body tag gen-recent-changes in wiki
- (page :: <wiki-page>, response :: <response>, do-body :: <function>)
+ (page :: <wiki-page>, do-body :: <function>)
(count)
let count = string-to-integer(get-query-value("count") | count);
for (i from 0 below count,
@@ -576,47 +565,43 @@
end;
define tag show-change-timestamp in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
()
- write(output-stream(response), print-date(*change*.timestamp));
+ output(print-date(*change*.timestamp));
end;
define tag show-change-title in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
()
- write(output-stream(response), *change*.wiki-page-content.page-title);
+ output(*change*.wiki-page-content.page-title);
end;
define tag show-change-version in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
()
- write(output-stream(response), integer-to-string(*change*.page-version));
+ output(integer-to-string(*change*.page-version));
end;
define tag show-change-author in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
()
- write(output-stream(response), escape-xml(*change*.author));
+ output(escape-xml(*change*.author));
end;
define tag show-change-comment in wiki
- (page :: <wiki-page>, response :: <response>)
+ (page :: <wiki-page>)
()
- write(output-stream(response), escape-xml(*change*.comment));
+ output(escape-xml(*change*.comment));
end;
-define page admin-page (<wiki-page>)
- (url: "/wiki/admin.dsp",
- source: "wiki/admin.dsp")
-end;
+define class <admin-page> (<wiki-page>) end;
+define variable *admin-page* = make(<admin-page>, source: "wiki/admin.dsp");
-define page version-page (<wiki-page>)
- (url: "/wiki/version.dsp",
- source: "wiki/version.dsp")
-end;
+define class <version-page> (<wiki-page>) end;
+define variable *version-page* = make(<version-page>, source: "wiki/version.dsp");
define body tag show-versions in wiki
- (page :: <wiki-page>, response :: <response>, do-body :: <function>)
+ (page :: <wiki-page>, do-body :: <function>)
()
for (version in reverse(find-page(*title*).revisions))
dynamic-bind (*change* = version)
@@ -626,7 +611,7 @@
end;
define method respond-to-get
- (page :: <version-page>, request :: <request>, response :: <response>)
+ (page :: <version-page>)
dynamic-bind (*title* = get-query-value("title"))
next-method();
end;
Added: trunk/libraries/registry/generic/http-client
==============================================================================
--- (empty file)
+++ trunk/libraries/registry/generic/http-client Fri May 2 12:58:04 2008
@@ -0,0 +1 @@
+abstract://dylan/network/http-client/http-client.lid
Added: trunk/libraries/registry/generic/http-client-test-suite
==============================================================================
--- (empty file)
+++ trunk/libraries/registry/generic/http-client-test-suite Fri May 2 12:58:04 2008
@@ -0,0 +1 @@
+abstract://dylan/network/http-client/http-client-test-suite/http-client-test-suite.lid
Added: trunk/libraries/registry/generic/http-protocol-test-suite
==============================================================================
--- (empty file)
+++ trunk/libraries/registry/generic/http-protocol-test-suite Fri May 2 12:58:04 2008
@@ -0,0 +1 @@
+abstract://dylan/network/http-client/http-protocol-test-suite/http-protocol-test-suite.lid
Added: trunk/libraries/registry/generic/koala-test-suite
==============================================================================
--- (empty file)
+++ trunk/libraries/registry/generic/koala-test-suite Fri May 2 12:58:04 2008
@@ -0,0 +1 @@
+abstract://dylan/network/koala/sources/koala-test-suite/koala-test-suite.lid
Modified: trunk/libraries/uri/uri.dylan
==============================================================================
--- trunk/libraries/uri/uri.dylan (original)
+++ trunk/libraries/uri/uri.dylan Fri May 2 12:58:04 2008
@@ -21,6 +21,14 @@
init-keyword: fragment:;
end;
+// FIXME -- Implement the following restrictions in the initialize method
+// for the <uri> class...
+// The scheme and path components are required, though the path may be
+// empty (no characters). When authority is present, the path must
+// either be empty or begin with a slash ("/") character. When
+// authority is not present, the path cannot begin with two slash
+// characters ("//").
+
define class <url> (<uri>) end;
define method uri-authority
@@ -178,7 +186,7 @@
end;
unless (empty?(uri.uri-authority))
result := concatenate(result, "//", uri.uri-authority);
- end;
+ end;
result := concatenate(result, build-path(uri));
unless (empty?(uri.uri-query))
result := concatenate(result, "?", build-query(uri));
More information about the chatter
mailing list