Author: dylan
Date: 2004-08-17 14:57:17 -0400 (Tue, 17 Aug 2004)
New Revision: 351
Modified:
trunk/main/server/NEWS
trunk/main/server/README
trunk/main/server/lib/Haver/Server/Object.pm
trunk/main/server/lib/Haver/Server/POE/Commands.pm
trunk/main/server/lib/Haver/Server/POE/Connection.pm
Log:
Slightly new protocol, INFO is dead.
The short lived EACH (which was never commited)
is also dead.
C: INFO $cid $ns [$id]
Modified: trunk/main/server/NEWS
===================================================================
--- trunk/main/server/NEWS 2004-08-17 18:16:23 UTC (rev 350)
+++ trunk/main/server/NEWS 2004-08-17 18:57:17 UTC (rev 351)
@@ -1,3 +1,5 @@
-* The server uses the new, saner, v3 protocol.
+* We're using the fourth version of the protocol...
+* Error names are now saner.
+* There's an INFO (like whois) command!
Modified: trunk/main/server/README
===================================================================
--- trunk/main/server/README 2004-08-17 18:16:23 UTC (rev 350)
+++ trunk/main/server/README 2004-08-17 18:57:17 UTC (rev 351)
@@ -1,4 +1,4 @@
-Haver-Server version 0.06 ("Lamp")
+Haver-Server version 0.07 ("Bond")
=========================
Haver's a new chat system similar to IRC,
@@ -34,7 +34,7 @@
DEPENDENCIES
POE => 0.27
-Haver => 0.04
+Haver => 0.07
YAML => 0.35
Digest::SHA1 => 2.01
Modified: trunk/main/server/lib/Haver/Server/Object.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Object.pm 2004-08-17 18:16:23 UTC
(rev 350)
+++ trunk/main/server/lib/Haver/Server/Object.pm 2004-08-17 18:57:17 UTC
(rev 351)
@@ -49,6 +49,7 @@
our $IdPattern ||= qr/&?[A-Za-z][A-Za-z0-9_'[EMAIL PROTECTED]/;
+our $NsPattern ||= qr/[a-z]+/;
our %Types = (
# '' => 'public',
'+' => 'broadcast',
@@ -292,10 +293,11 @@
}
sub is_valid_id {
- my ($this, $uid) = @_;
+ my ($this, $id) = @_;
- if (defined $uid && $uid =~ /^$IdPattern$/) {
- if (length($uid) > 2 and length($uid) < 20) {
+ return 1 if $id eq '&';
+ if (defined $id && ($id =~ /^$IdPattern$/)) {
+ if (length($id) > 2 and length($id) < 20) {
return 1;
} else {
return 0;
@@ -305,6 +307,20 @@
}
}
+sub is_valid_ns {
+ my ($this, $ns) = @_;
+
+ if (defined $ns && $ns =~ /^$NsPattern$/) {
+ if (length($ns) > 2 and length($ns) < 20) {
+ return 1;
+ } else {
+ return 0;
+ }
+ } else {
+ return 0;
+ }
+}
+
sub namespaces {
my ($me) = @_;
my @ns = ();
Modified: trunk/main/server/lib/Haver/Server/POE/Commands.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE/Commands.pm 2004-08-17 18:16:23 UTC
(rev 350)
+++ trunk/main/server/lib/Haver/Server/POE/Commands.pm 2004-08-17 18:57:17 UTC
(rev 351)
@@ -42,10 +42,9 @@
JOIN PART BYE
HAVER
INFO
- LINFO
MARK
- USERS
- CHANS
+ LIST
+ INFO
);
@@ -61,32 +60,21 @@
# $cmds{cmd_GRANT} = 'cmd_GRANTCMD';
# $cmds{cmd_REVOKE} = 'cmd_GRANTCMD';
# $cmds{cmd_CLEAR} = 'cmd_GRANTCMD';
-
return \%cmds;
}
-#> [HAVER]
-#> C: HAVER $client
-#> S: HAVER $server
sub cmd_HAVER {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my $client = $args->[0];
+ return if exists $heap->{client};
+
$heap->{socket}->put(['HAVER',
"Haver::Server::POE/$Haver::Server::POE::VERSION"]);
$heap->{client} = $client;
$kernel->yield('want', 'IDENT');
}
-#> [IDENT]
-#> C: IDENT $id [$ns]
-#> S: ACCEPT $id
-#> | WANT AUTH ...
-#> Errors:
-#> * ns-unknown -- %1 is an unknown type (namespace) of client.
-#> * syntax -- %1 this is an illegal id.
-#> * reserved -- %1 is reserved for something else.
-#> * used -- %1 is already being used.
sub cmd_IDENT {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my ($id, $ns) = @$args;
@@ -95,7 +83,8 @@
return if $heap->{login};
if ($ns ne 'user') {
- $kernel->yield('die', 'ns-unknown', [$ns]);
+ $kernel->yield('fail', 'IDENT', 'unsupported.ns', [$ns]);
+ $kernel->yield('want', 'IDENT');
return;
}
@@ -139,9 +128,6 @@
}
}
-#> [CANT]
-#> C: CANT $want
-#> S: ...
sub cmd_CANT {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my $want = $args->[0];
@@ -158,11 +144,6 @@
}
}
-#> [AUTH]
-#> C: AUTH $method ...
-#> S: WANT AUTH:uc($method) ...
-#> Errors:
-#> * unknown -- auth method %1 is unknown
sub cmd_AUTH {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my $method = $args->[0];
@@ -178,11 +159,6 @@
}
-#> [AUTH:PASS]
-#> C: AUTH:PASS $password
-#> S: ACCEPT $id
-#> Errors:
-#> * nomatch -- password did not match,
sub cmd_AUTH_PASS {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my ($pass) = @$args;
@@ -210,12 +186,6 @@
}
-#> [MSG]
-#> C: MSG $cid $type @args
-#> S: MSG $cid $uid $type @args
-#> Errors:
-#> * syntax -- the cid %1 is invalid.
-#> * notfound -- the cid %1 was not found.
sub cmd_MSG {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my ($cid, $type) = (shift @$args, shift @$args);
@@ -228,12 +198,6 @@
['MSG', $chan->id, $heap->{uid}, $type, @$args]);
}
-#> [PMSG]
-#> C: PMSG $uid $type @args
-#> S: PMSG $uid $type @args
-#> Errors:
-#> * syntax -- the uid %1 is invalid.
-#> * notfound -- the uid %1 was not found.
sub cmd_PMSG {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my $uid = shift @$args;
@@ -244,13 +208,6 @@
$user->put(['PMSG', $heap->{uid}, @$args]);
}
-#> [JOIN]
-#> C: JOIN $cid
-#> S: JOIN $cid $uid
-#> Errors:
-#> * notfound -- the cid %1 was not found.
-#> * syntax -- the cid %1 is invalid.
-#> * joined -- tried to join %1 while already in it.
sub cmd_JOIN {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my $cid = shift @$args;
@@ -268,13 +225,6 @@
$kernel->post('Broadcaster', 'send', $users, ['JOIN', $cid, $user->id]);
}
-#> [PART]
-#> C: PART $cid
-#> S: PART $cid $uid
-#> Errors:
-#> * notfound.cid -- the cid %1 was not found.
-#> * syntax.cid -- the cid %1 is invalid.
-#> * timetravel -- you tried to part %1 before you joined it...
sub cmd_PART {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my $cid = shift @$args;
@@ -293,64 +243,66 @@
}
-#> [BYE]
-#> C: BYE [$reason]
-#> S: BYE ACTIVE [$reason]
sub cmd_BYE {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
$kernel->yield('shutdown', 'ACTIVE', @$args);
}
-#> [INFO]
-#> C: INFO $ns $id
-#> S: INFO $ns $id (list of key value pairs)
-#> Errors:
-#> * notfound -- the id %2 of namespace %1 was not found.
-#> * syntax -- the id %2 of namespace %1 is invalid.
sub cmd_INFO {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my ($ns, $id) = @$args;
- my $obj = check_id($ns, $id, 'INFO') or return;
-
- my @keys = eval { @{ $obj->get('_info') } };
- my @out = ('INFO', $ns, $id, map { ($_ => $obj->get($_)) } @keys);
-
- $heap->{socket}->put([EMAIL PROTECTED]);
-}
-
-#> [LINFO]
-#> C: LINFO $cid $ns $id
-#> S: LINFO $cid $ns $id (key-value pairs)
-#> Errors:
-#> * notfound -- the ns/id combination %1/%2 was not found.
-#> * notfound.cid -- the cid %1 was not found.
-#> * syntax -- the id %2 of namespace %1 is invalid.
-#> * syntax.cid -- the cid %1 is invalid.
-sub cmd_LINFO {
- my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
my ($cid, $ns, $id) = @$args;
- my $chan = check_cid($cid, 'LINFO', 'cid') or return;
+ my $chan = $cid eq '&' ? $Registry : check_cid($cid, "INFO");
+ return unless $chan;
my @m = $heap->{scope}{mark} ? ('MARK', $heap->{scope}{mark}) : ();
- if ($id ne '*') {
- my $user = check_id($ns, $id, 'LINFO') or return;
-
+ if (defined $id) {
+ my $user = check_id($ns, $id, 'LINFO', [$ns, $id], 'id') or
return;
my @keys = @{ $user->get('_info') };
- my @out = (@m, 'LINFO', $cid, $id, map { ($_ => $user->get($_))
} @keys);
-
+ my @out = (@m, 'INFO', $cid, $ns, $id, map { ($_ =>
$user->get($_)) } @keys);
$heap->{socket}->put([EMAIL PROTECTED]);
} else {
- foreach my $user ($chan->contents('user')) {
- my @keys = @{ $user->get('_info') };
- my @out = (@m, 'LINFO', $cid, $user->id, map { ($_ =>
$user->get($_)) } @keys);
+ foreach my $obj ($chan->contents($ns)) {
+ my @keys = @{ $obj->get('_info') };
+ my @out = (@m, 'INFO', $cid, $ns, $obj->id, map { ($_
=> $obj->get($_)) } @keys);
$heap->{socket}->put([EMAIL PROTECTED]);
}
+ $heap->{socket}->put(['END', 'INFO']);
}
}
+
+#> LIST($cid, $ns)
+sub cmd_LIST {
+ my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ my ($cid, $ns) = @$args;
+ my $chan;
+
+ if (@$args == 1) {
+ $ns = $cid;
+ $cid = '&';
+ $chan = $Registry;
+ } else {
+ $chan = check_cid($cid, 'LIST') or return;
+ }
+ check_ns($ns, 'LIST') or return;
+ my @list = ('LIST', $cid, $ns, map { $_->id } $chan->contents($ns));
+
+ $heap->{socket}->put([EMAIL PROTECTED]);
+}
+
+sub cmd_POKE {
+ my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ my ($data) = @$args;
+ my $now = time;
+
+ my $datetime = Haver::Util::Misc::format_datetime($now);
+ $heap->{socket}->put(['OUCH', $datetime, $data ? $data : () ]);
+}
+
+
sub err {
my ($s, $d) = @_;
@@ -365,8 +317,11 @@
$poe_kernel->yield('fail', $cmd, err('syntax', $d), $arg);
return undef;
}
+ unless (check_ns($ns, $cmd)) {
+ return undef;
+ }
unless ($Registry->contains($ns, $id)) {
- $poe_kernel->yield('fail', $cmd, err('notfound', $d), $arg);
+ $poe_kernel->yield('fail', $cmd, err('unknown', $d), $arg);
return undef;
}
@@ -375,14 +330,33 @@
sub check_cid {
my ($id, $cmd, $rest, $d) = @_;
-
+
+ $d ||= 'cid';
+
check_id('channel', $id, $cmd, $rest, $d);
}
sub check_uid {
my ($id, $cmd, $rest, $d) = @_;
+ $d ||= 'uid';
check_id('user', $id, $cmd, $rest, $d);
}
+sub check_ns {
+ my ($ns, $cmd) = @_;
+
+ unless (Haver::Server::Object->is_valid_ns($ns)) {
+ $poe_kernel->yield('fail', $cmd, 'syntax.ns', [$ns]);
+ return undef;
+ }
+
+ if ($ns ne 'user' and $ns ne 'channel') {
+ $poe_kernel->yield('fail', $cmd, 'unknown.ns', [$ns]);
+ return undef;
+ }
+
+ return 1;
+}
+
1;
Modified: trunk/main/server/lib/Haver/Server/POE/Connection.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE/Connection.pm 2004-08-17
18:16:23 UTC (rev 350)
+++ trunk/main/server/lib/Haver/Server/POE/Connection.pm 2004-08-17
18:57:17 UTC (rev 351)
@@ -41,7 +41,8 @@
# ASSERT: (@_ == 1 and ref($_[0]) eq 'HASH') or ((@_ % 2) == 0);
my $opts = @_ == 1 ? $_[0] : { @_ };
-
+ my $commands = 'Haver::Server::POE::Commands';
+
POE::Session->create(
package_states => [
$class => {
@@ -66,6 +67,7 @@
auth => 'on_auth',
unknown_cmd => 'on_unknown_cmd',
},
+ $commands => $commands->commands,
],
heap => {},
args => [ $opts ],
