[Gd-chatter] r11085 - in trunk/libraries/network: koala/sources/examples/buddha web-framework xmpp xmpp-bot
hannes at gwydiondylan.org
hannes at gwydiondylan.org
Wed Dec 20 21:59:39 CET 2006
Author: hannes
Date: Wed Dec 20 21:59:35 2006
New Revision: 11085
Modified:
trunk/libraries/network/koala/sources/examples/buddha/buddha.dylan
trunk/libraries/network/koala/sources/examples/buddha/config.dylan
trunk/libraries/network/koala/sources/examples/buddha/zone.dylan
trunk/libraries/network/web-framework/change.dylan
trunk/libraries/network/web-framework/command.dylan
trunk/libraries/network/web-framework/library.dylan
trunk/libraries/network/xmpp-bot/library.dylan
trunk/libraries/network/xmpp-bot/module.dylan
trunk/libraries/network/xmpp-bot/xmpp-bot.dylan
trunk/libraries/network/xmpp/message.dylan
Log:
Bug: 7257
xmpp: added support for xml element in a body of a message
xmpp-bot: added support for xml element in a body of a message
web-framework:
* implemented print-change generic function (which returns a string)
* added support for a base-url keyword to send uris, not only relative links
(in print-change and print-xml)
* export valid-user? GF
buddha:
* hardcoded ns.ripe.net as authoritative NS for ipv4 reverse delegations
* fix printing of dhcpd config file
* use xmpp bot for changes
* use http authentication instead of cookies and http forms
Modified: trunk/libraries/network/koala/sources/examples/buddha/buddha.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/examples/buddha/buddha.dylan (original)
+++ trunk/libraries/network/koala/sources/examples/buddha/buddha.dylan Wed Dec 20 21:59:35 2006
@@ -33,7 +33,7 @@
body {
h1("Welcome to buddha, please create an initial admin-user!"),
div(id => "content") {
- do(add-form(<user>, "Users", storage(<user>), refer: "login")),
+ do(add-form(<user>, "Users", storage(<user>), refer: "network")),
b("Please choose root as access level to be able to add new users!")
}
}
@@ -49,45 +49,37 @@
{ define page ?:name end }
=> { define responder ?name ## "-responder" ("/" ## ?"name")
(request, response)
- block(return)
- if (storage(<user>).size = 0)
- initial-responder(request, response);
+ if (storage(<user>).size = 0)
+ initial-responder(request, response);
+ else
+ let good? = #f;
+ block(return)
+ let auth = header-value(#"authorization");
+ unless (auth)
return();
- end;
- //dns, dhcp shouldn't need a valid user
- //(to get it working with wget and stuff, without needing cookies)
- unless (logged-in?(request))
- let username = get-query-value("username");
- let password = get-query-value("password");
- login(request, username, password);
- unless (logged-in?(request))
- //error
- respond-to-get(#"login", request, response,
- errors: list(make(<web-error>,
- error: "No valid user supplied\n")));
+ end;
+ unless (valid-user?(auth.head, auth.tail))
return();
end;
- end;
- dynamic-bind(*user* = current-user())
- if (request.request-method = #"get")
- respond-to-get(?#"name", request, response)
- elseif (request.request-method = #"post")
- respond-to-post(?#"name", request, response)
+ dynamic-bind(*user* = storage(<user>)[auth.head])
+ good? := #t;
+ if (request.request-method = #"get")
+ respond-to-get(?#"name", request, response)
+ elseif (request.request-method = #"post")
+ respond-to-post(?#"name", request, response)
+ end;
end;
end;
+ unless (good?)
+ let headers = response.response-headers;
+ add-header(headers, "WWW-Authenticate",
+ "Basic realm=\"buddha requires authentication!\"");
+ unauthorized-error(headers: headers);
+ end;
end;
end; }
end;
-define responder default-responder ("/")
- (request, response)
- if (storage(<user>).size = 0)
- initial-responder(request, response);
- else
- respond-to-get(#"login", request, response);
- end;
-end;
-
define page network end;
define page network-detail end;
define page subnet end;
@@ -102,7 +94,6 @@
define page edit end;
define page changes end;
define page adduser end;
-define page logout end;
define page add end;
define page admin end;
@@ -125,12 +116,19 @@
end;
define responder dhcp-responder ("/dhcp")
(request, response)
- respond-to-get(#"dhcp", request, response);
+ respond-to-get(#"dhcp", request, response);
end;
define responder tinydns-responder ("/tinydns")
(request, response)
- respond-to-get(#"tinydns", request, response);
+ respond-to-get(#"tinydns", request, response);
+end;
+
+define responder root ("/")
+ (request, response)
+ moved-permanently-redirect(location: "/vlan",
+ header-name: "Location",
+ header-value: "/vlan");
end;
define macro with-buddha-template
@@ -196,9 +194,7 @@
end;
end if),
ul { li{ text("Logged in as "),
- strong(*user*.username),
- text(" "),
- a("logout", href => "/logout") } }
+ strong(*user*.username) } }
}
},
do(?body)
@@ -260,49 +256,6 @@
end;
end;
-define method respond-to-get (page == #"logout",
- request :: <request>,
- response :: <response>,
- #key errors = #());
- clear-session(request);
- respond-to-get(#"login", request, response);
-end;
-
-define method respond-to-get (page == #"login",
- request :: <request>,
- response :: <response>,
- #key errors = #())
- let out = output-stream(response);
- format(out, "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n");
- let page = with-xml-builder()
-html(xmlns => "http://www.w3.org/1999/xhtml") {
- head {
- title("Buddha - Login"),
- link(rel => "stylesheet", href => "/buddha.css")
- },
- body {
- do(show-errors(errors)),
- h1("Please login to buddha"),
- form(action => "/network", \method => "post") {
- div(class => "edit") {
- text("Username "),
- input(type => "text",
- name => "username"),
- br,
- text("Password "),
- input(type => "password",
- name => "password"),
- br,
- input(type => "submit",
- value => "Login")
- }
- }
- }
-}
- end;
- format(out, "%=", page);
-end;
-
define method respond-to-get (page == #"add",
request :: <request>,
@@ -1182,10 +1135,18 @@
format(out, "%=", page);
end;
-/*define method save (change :: <change>) => ()
+define method save (change :: <change>) => ()
next-method();
block ()
- broadcast-message(*xmpp-bot*, as(<string>, with-xml() html { do(print-xml(change)) } end));
+// let message
+// = with-xml()
+// html (xmlns => "http://jabber.org/protocol/xhtml-im") {
+// body (xmlns => "http://www.w3.org/1999/xhtml") { div {
+// do(print-xml(change, base-url: "https://buddha.zaphods.net")) } } }
+// end;
+ let message = print-change(change, base-url: "https://buddha.zaphods.net");
+ format-out("Sending %s\n", message);
+ broadcast-message(*xmpp-bot*, message);
exception (e :: <condition>)
xmpp-worker();
end;
@@ -1195,14 +1156,14 @@
define function xmpp-worker ()
block()
- *xmpp-bot* := make(<xmpp-bot>, jid: "buddha at jabber.berlin.ccc.de", password: "fnord");
+ *xmpp-bot* := make(<xmpp-bot>, jid: "buddha at jabber.berlin.ccc.de/serva", password: "fnord");
+ sleep(3); //this is for safety reasons, xml-parser is not thread-safe!
exception (e :: <condition>)
*xmpp-bot* := #f
end;
-end; */
+end;
define function main () => ()
- //xmpp-worker();
- //sleep(3);
+ xmpp-worker();
register-url("/buddha.css", maybe-serve-static-file);
block()
start-server();
Modified: trunk/libraries/network/koala/sources/examples/buddha/config.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/examples/buddha/config.dylan (original)
+++ trunk/libraries/network/koala/sources/examples/buddha/config.dylan Wed Dec 20 21:59:35 2006
@@ -230,7 +230,7 @@
define method print-isc-dhcpd-file (config :: <collection>, stream :: <stream>)
=> ()
for (network in config)
- if (network.dhcp?)
+ if (instance?(network, <ipv4-network>) & network.dhcp?)
print-isc-dhcpd-file(network, stream);
end;
end;
Modified: trunk/libraries/network/koala/sources/examples/buddha/zone.dylan
==============================================================================
--- trunk/libraries/network/koala/sources/examples/buddha/zone.dylan (original)
+++ trunk/libraries/network/koala/sources/examples/buddha/zone.dylan Wed Dec 20 21:59:35 2006
@@ -143,14 +143,6 @@
// print-zone.refresh, print-zone.retry,
// print-zone.expire, print-zone.minimum,
// print-zone.time-to-live);
- //reverse zones for networks
- do(method(x)
- format(stream, "Z%s:%s.:%s.\n",
- x, print-zone.nameservers[0].ns-name, print-zone.hostmaster);
- do(method(y)
- format(stream, "&%s::%s.\n", x, y.ns-name)
- end, print-zone.nameservers);
- end, apply(concatenate, map(get-reverse-cidrs, storage(<network>))));
//nameserver
do(method(x)
format(stream, "&%s::%s.\n", print-zone.zone-name, x.ns-name)
@@ -160,6 +152,17 @@
format(stream, "@%s::%s.%s:%d\n",
print-zone.zone-name, mx-name(x), print-zone.zone-name, priority(x));
end, print-zone.mail-exchanges);
+ //reverse zones for networks
+ do(method(x)
+ format(stream, "Z%s:%s.:%s.\n",
+ x, print-zone.nameservers[0].ns-name, print-zone.hostmaster);
+ do(method(y)
+ format(stream, "&%s::%s.\n", x, y.ns-name)
+ end, print-zone.nameservers);
+ if (subsequence-position(x, "in-addr.arpa"))
+ format(stream, "&%s::%s.\n", x, "ns.ripe.net")
+ end;
+ end, apply(concatenate, map(get-reverse-cidrs, storage(<network>))));
//Hosts
do(method(x)
format(stream, "=%s.%s:%s:%d\n",
@@ -201,38 +204,4 @@
end, print-zone.cnames);
end;
-define method parse-cidr (zone-name :: <string>) => (network :: <network>)
- //zone-name is something like "1.2.3.in-addr.arpa." for the network 3.2.1.0/24
- let parts = split(zone-name, '.');
- let network-string
- = concatenate(parts[2], ".", parts[1], ".", parts[0], ".0");
- make(<network>, cidr: make(<cidr>,
- network-address: make(<ip-address>, data: network-string),
- netmask: 24));
-end;
-define method add-reverse-zones (network :: <network>) => ()
- //XXX: add hostmaster, mx, nameserver,...
- let rev-mask = truncate/(network.cidr.cidr-netmask, 8) * 8;
- for (subnet in split-cidr(network.cidr, rev-mask))
- let zone = make(<zone>,
- reverse?: #t,
- zone-name: cidr-to-reverse-zone(subnet),
- visible?: #f);
- block(ret)
- check(zone);
- let command = make(<add-command>,
- arguments: list(zone, storage(<zone>)));
- let change = make(<change>,
- command: command);
- save(change);
- redo(command);
- signal(make(<web-success>,
- warning: concatenate("Added zone: ", show(zone))));
- exception (e :: <web-error>)
- signal(make(<web-form-warning>,
- warning: concatenate("Couldn't add reverse zone, error was: ", e.error-string)));
- ret();
- end;
- end;
-end;
Modified: trunk/libraries/network/web-framework/change.dylan
==============================================================================
--- trunk/libraries/network/web-framework/change.dylan (original)
+++ trunk/libraries/network/web-framework/change.dylan Wed Dec 20 21:59:35 2006
@@ -29,7 +29,13 @@
save(change);
end;
-define method print-xml (date :: <date>)
+define method print-xml (date :: <date>, #key base-url)
+ list(with-xml()
+ text(print-change(date))
+ end);
+end;
+
+define method print-change (date :: <date>, #key base-url)
let $month-names
= #["Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"];
@@ -43,22 +49,22 @@
integer-to-string(i)
end;
end;
- let printed-date
- = concatenate(integer-to-string(iday), " ",
- $month-names[imonth - 1], " ",
- //integer-to-string(iyear), " ",
- wrap0(ihours), ":",
- wrap0(iminutes), ":",
- wrap0(iseconds));
- list(with-xml()
- text(printed-date)
- end);
+ concatenate(integer-to-string(iday), " ",
+ $month-names[imonth - 1], " ",
+ //integer-to-string(iyear), " ",
+ wrap0(ihours), ":",
+ wrap0(iminutes), ":",
+ wrap0(iseconds));
end;
-
-define method print-xml (change :: <change>)
+define method print-xml (change :: <change>, #key base-url)
concatenate(print-xml(change.date),
list(with-xml()
text(concatenate(" by ", change.author, ": "))
end),
- print-xml(change.command));
+ print-xml(change.command, base-url: base-url));
+end;
+
+define method print-change (change :: <change>, #key base-url)
+ concatenate(print-change(change.date), " by ", change.author, ": ",
+ print-change(change.command, base-url: base-url))
end;
Modified: trunk/libraries/network/web-framework/command.dylan
==============================================================================
--- trunk/libraries/network/web-framework/command.dylan (original)
+++ trunk/libraries/network/web-framework/command.dylan Wed Dec 20 21:59:35 2006
@@ -59,30 +59,43 @@
unset-slots;
end;
-define method print-xml (command :: <command>)
+define method print-xml (command :: <command>, #key base-url)
let object = command.arguments[0];
let type = get-url-from-type(object.object-class);
with-xml()
a(concatenate(type, " ", show(object)),
- href => concatenate("/", type, "-detail?", type, "=", get-reference(object)))
+ href => concatenate(if (base-url) base-url else "" end, "/", type, "-detail?", type, "=", get-reference(object)))
end;
end;
-define method print-xml (command :: <add-command>)
+define method print-change (command :: <command>, #key base-url) => (res :: <string>)
+ let object = command.arguments[0];
+ let type = get-url-from-type(object.object-class);
+ concatenate(type, " ", show(object), " ",
+ if (base-url) base-url else "" end,
+ "/", type, "-detail?", type, "=", get-reference(object))
+end;
+define method print-xml (command :: <add-command>, #key base-url)
list(with-xml()
text("Added ")
end,
next-method());
end;
-define method print-xml (command :: <remove-command>)
+define method print-change (command :: <add-command>, #key base-url)
+ concatenate("Added ", next-method());
+end;
+define method print-xml (command :: <remove-command>, #key base-url)
list(with-xml()
text("Removed ")
end,
next-method())
end;
-define method print-xml (command :: <edit-command>)
+define method print-change (command :: <remove-command>, #key base-url)
+ concatenate("Removed ", next-method());
+end;
+define method print-xml (command :: <edit-command>, #key base-url)
list(with-xml()
text("Edited ")
end,
@@ -97,7 +110,12 @@
end)
end;
-define method print-xml (triple :: <triple>)
+define method print-change (command :: <edit-command>, #key base-url)
+ apply(concatenate, "Edited ", next-method(), ", changed following slots:\n",
+ map(print-change, command.arguments[1]));
+end;
+
+define method print-xml (triple :: <triple>, #key base-url)
with-xml()
li { text(concatenate(triple.slot-name,
" from \"", show(triple.old-value),
@@ -106,6 +124,11 @@
end;
end;
+define method print-change (triple :: <triple>, #key base-url)
+ concatenate(triple.slot-name, " from \"", show(triple.old-value),
+ "\" to \"", show(triple.new-value), "\"\n");
+end;
+
define method add-to-list (object :: <object>, list :: <collection>)
//only add if not in list
unless (any?(method(x) x = object end, list))
Modified: trunk/libraries/network/web-framework/library.dylan
==============================================================================
--- trunk/libraries/network/web-framework/library.dylan (original)
+++ trunk/libraries/network/web-framework/library.dylan Wed Dec 20 21:59:35 2006
@@ -111,7 +111,8 @@
access-level-setter,
current-user,
login,
- logged-in?;
+ logged-in?,
+ valid-user?;
end;
define module change
@@ -132,7 +133,8 @@
command,
undo,
redo,
- print-xml;
+ print-xml,
+ print-change;
//commands
export <add-command>,
Modified: trunk/libraries/network/xmpp-bot/library.dylan
==============================================================================
--- trunk/libraries/network/xmpp-bot/library.dylan (original)
+++ trunk/libraries/network/xmpp-bot/library.dylan Wed Dec 20 21:59:35 2006
@@ -7,7 +7,7 @@
use io;
use system;
use xmpp;
- use xml-parser, import: { simple-xml };
+ use xml-parser, import: { simple-xml, xml-parser };
// Add any more module exports here.
export xmpp-bot;
Modified: trunk/libraries/network/xmpp-bot/module.dylan
==============================================================================
--- trunk/libraries/network/xmpp-bot/module.dylan (original)
+++ trunk/libraries/network/xmpp-bot/module.dylan Wed Dec 20 21:59:35 2006
@@ -10,6 +10,7 @@
use standard-io;
use xmpp;
use simple-xml;
+ use xml-parser;
// Add binding exports here.
export <xmpp-bot>, broadcast-message;
Modified: trunk/libraries/network/xmpp-bot/xmpp-bot.dylan
==============================================================================
--- trunk/libraries/network/xmpp-bot/xmpp-bot.dylan (original)
+++ trunk/libraries/network/xmpp-bot/xmpp-bot.dylan Wed Dec 20 21:59:35 2006
@@ -84,7 +84,7 @@
end;
end;
-define method broadcast-message (bot :: <xmpp-bot>, message :: <string>)
+define method broadcast-message (bot :: <xmpp-bot>, message :: type-union(<string>, <element>))
do(method (user)
send(bot.client,
make(<message>,
Modified: trunk/libraries/network/xmpp/message.dylan
==============================================================================
--- trunk/libraries/network/xmpp/message.dylan (original)
+++ trunk/libraries/network/xmpp/message.dylan Wed Dec 20 21:59:35 2006
@@ -60,6 +60,11 @@
body;
end method body-setter;
+define method body-setter (body :: <element>, message :: <message>)
+ => (res :: <element>)
+ remove-element(message, "body");
+ add-element(message, body);
+end;
define method body-setter (body == #f, message :: <message>)
=> (res);
remove-element(message, "body");
More information about the chatter
mailing list