Author: dylan
Date: 2004-07-23 02:13:23 -0400 (Fri, 23 Jul 2004)
New Revision: 325
Modified:
trunk/main/server/lib/Haver/Server/Object.pm
trunk/main/server/lib/Haver/Server/Object/User.pm
trunk/main/server/lib/Haver/Server/POE.pm
trunk/main/server/lib/Haver/Server/POE/Commands.pm
trunk/main/server/lib/Haver/Server/POE/Connection.pm
Log:
Removed flags, added INFO command,
and MARK command (which is a hack, nothing
should use it except Jarverd).
Documentation is to come.
Changing error names now,
to saner things. They look like exceptions,
e.g. "syntax.id" instead of "UID_INVALID"...
I'll re-write the error formatting client module
ASAP.
Modified: trunk/main/server/lib/Haver/Server/Object/User.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Object/User.pm 2004-07-23 06:11:30 UTC
(rev 324)
+++ trunk/main/server/lib/Haver/Server/Object/User.pm 2004-07-23 06:13:23 UTC
(rev 325)
@@ -37,7 +37,6 @@
$me->set(
'+role' => 'user',
);
- $me->set_flags('+role', 'lip');
Modified: trunk/main/server/lib/Haver/Server/Object.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Object.pm 2004-07-23 06:11:30 UTC
(rev 324)
+++ trunk/main/server/lib/Haver/Server/Object.pm 2004-07-23 06:13:23 UTC
(rev 325)
@@ -47,18 +47,8 @@
our $VERSION = 0.04;
our $StorageDir ||= './store';
-our %Flags = (
- broadcast => 'pi',
- public => 'pi',
- private => 'p',
- secret => 'l',
- flag => '',
- attrib => 'pl',
-);
-
-our $IdPattern ||= qr/[a-z][a-z0-9_'.-]+/;
-
+our $IdPattern ||= qr/&?[A-Za-z][A-Za-z0-9_'[EMAIL PROTECTED]/;
our %Types = (
# '' => 'public',
'+' => 'broadcast',
@@ -95,7 +85,6 @@
$me->SUPER::initialize();
$me->{_fields} = {};
- $me->{_flags} = {};
$me->{id} ||= $ID++;
my @ns = @{ (delete $me->{namespaces}) || [] };
@@ -137,41 +126,6 @@
return wantarray ? @dirs : [EMAIL PROTECTED];
}
-## Flag methods
-sub get_flags {
- my ($me, $key) = @_;
-
- if (exists $me->{_flags}{$key}) {
- return $me->{_flags}{$key};
- } else {
- return $Flags{ $me->field_type($key) };
- }
-}
-sub set_flags {
- my ($me, $key, $value) = @_;
- $me->{_flags}{$key} = $value;
-}
-
-sub has_flags {
- my ($me, $key, $flags) = @_;
-
- for my $flag (split(//, $flags)) {
- unless ($me->has_flag($key, $flag)) {
- return 0;
- }
- }
-
- return 1;
-}
-
-sub has_flag {
- my ($me, $key, $flag) = @_;
- my $s = $me->get_flags($key);
-
- return undef unless defined $s;
- return index($s, $flag) != -1;
-}
-
## Methods for accessing fields.
sub set {
my ($me, @set) = @_;
@@ -180,20 +134,32 @@
$me->{_fields}{$k} = $v;
}
}
+
sub get {
my ($me, @keys) = @_;
if (@keys <= 1) {
- return $me->{_fields}{$keys[0]};
+ return _val($me->{_fields}{$keys[0]}, $me);
}
my @values;
foreach my $key (@keys) {
- push(@values, $me->{_fields}{$key});
+ push(@values, _val($me->{_fields}{$key}, $me));
}
return wantarray ? @values : [EMAIL PROTECTED] ;
}
+
+sub _val {
+ return $_[0] if not ref $_[0];
+
+ if (ref($_[0]) eq 'CODE') {
+ return $_[0]->($_[1]);
+ } else {
+ return $_[0];
+ }
+}
+
sub has {
my ($me, @keys) = @_;
@@ -238,15 +204,11 @@
ID => $me->id,
NS => $me->namespace,
fields => \%fields,
- flags => \%flags
);
foreach my $f ($me->list_fields) {
- if ($me->has_flag($f, 'p')) {
- $fields{$f} = $me->{_fields}{$f};
- }
+ $fields{$f} = $me->{_fields}{$f};
}
- %flags = %{ $me->{_flags} };
File::Path::mkpath($me->directory);
return \%data;
@@ -256,7 +218,6 @@
my ($me) = @_;
$me->{_fields} = (delete $me->{'-default'}{fields}) || {};
- $me->{_flags} = (delete $me->{'-default'}{flags}) || {};
delete $me->{'-default'};
1;
@@ -272,7 +233,6 @@
use warnings;
%{$me->{_fields}} = (%{$me->{_fields}}, %{delete $data->{fields}});
- %{$me->{_flags}} = (%{$me->{_flags}}, %{delete $data->{flags}});
1;
}
@@ -330,7 +290,7 @@
sub add {
my ($me, $object) = @_;
- my $id = $object->id;
+ my $id = lc $object->id;
my $ns = $object->namespace;
if (not($me->contains($ns, $id)) && $me->can_contain($object)) {
@@ -347,7 +307,7 @@
croak "fetch must be called with exactly three arguments!";
}
- return $me->{".$ns"}{$id} if $me->contains($ns, $id);
+ return $me->{".$ns"}{lc $id} if $me->contains($ns, $id);
}
sub contains {
@@ -355,7 +315,8 @@
if (@_ != 3) {
croak "contains must be called with exactly three arguments!";
}
-
+
+ $id = lc $id;
delete $me->{".$ns"}{$id} unless defined $me->{".$ns"}{$id};
return exists $me->{".$ns"}{$id};
}
@@ -373,14 +334,15 @@
} else {
die "Wrong number of arguments.";
}
- delete $me->{".$ns"}{$id};
+ delete $me->{".$ns"}{lc $id};
}
sub list_ids {
my ($me, $ns) = @_;
my $h = $me->{".$ns"};
+ my @v = map { $_->id } values %$h;
- wantarray ? keys %$h : [ keys %$h ];
+ wantarray ? @v : [EMAIL PROTECTED];
}
sub list_vals {
my ($me, $ns) = @_;
Modified: trunk/main/server/lib/Haver/Server/POE/Commands.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE/Commands.pm 2004-07-23 06:11:30 UTC
(rev 324)
+++ trunk/main/server/lib/Haver/Server/POE/Commands.pm 2004-07-23 06:13:23 UTC
(rev 325)
@@ -41,7 +41,7 @@
AUTH:PASS
IN TO
MSG JOIN PART QUIT
- USERS
+ USERS CHANS INFO MARK
);
@@ -66,26 +66,28 @@
sub do_unknown_cmd {
my ($kernel, $heap, $event, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
- $kernel->yield('warn', UCMD => [$event], $heap->{scope}{cid});
+ $kernel->yield('warn', 'unknown.cmd' => [$event], $heap->{scope}{cid});
}
-#> IDENT($uid, $mode, $version)
+#> IDENT($uid, $type)
sub cmd_IDENT {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my ($uid, $mode, $version) = @$args;
+ my ($uid, $type, $client) = @$args;
return if $heap->{login};
- if ($mode ne 'user') {
- $kernel->yield('die', 'UNSUPPORTED_MODE', [$mode]);
+ if ($type ne 'user') {
+ $kernel->yield('die', 'unknown.type', [$type]);
return;
}
unless (Haver::Server::Object::User->is_valid_id($uid)) {
- $poe_kernel->yield('die', 'UID_INVALID', [$uid]);
+ $poe_kernel->yield('die', 'syntax.id.user', [$uid]);
+ } elsif ($type eq 'user' and ($uid =~ /&/ or $uid =~ /@/)) {
+ $poe_kernel->yield('die', 'reserved.id.user', [$uid]);
} else {
if ($Registry->contains('user', $uid)) {
- $poe_kernel->yield('die', 'UID_IN_USE', [$uid]);
+ $poe_kernel->yield('die', 'exists.user', [$uid]);
} else {
my $user = new Haver::Server::Object::User(
id => $uid,
@@ -93,17 +95,18 @@
sid => $_[SESSION]->ID,
);
$user->set(
- mode => $mode,
- version => $version
+ ClientType => $type,
+ Client => $client,
+ Rank => 0,
+ Role => 'User',
);
- $user->set_flags('mode', 'l');
- $user->set_flags('version', 'i');
if (-e $user->filename) {
eval { $user->load };
if ($@) {
# This really shouldn't ever happen.
- $kernel->post('Logger', 'error', "Error
loading ${uid}: $@");
- $kernel->yield('die', 'LOAD_USER');
+ my $t = localtime;
+ $kernel->post('Logger', 'error', "<$t>
Error loading ${uid}: $@");
+ $kernel->yield('die', 'impossible',
[$t]);
return;
}
$kernel->yield('auth', $uid, $user);
@@ -111,6 +114,7 @@
$kernel->yield('accept', $uid, $user);
}
}
+
}
}
@@ -124,11 +128,11 @@
if (my $code = delete $heap->{want_data}{code}) {
$code->($kernel, $heap);
} else {
- $kernel->yield('die', 'CANT', [$want]);
+ $kernel->yield('die', 'cant', [$want]);
}
$heap->{want} = undef;
} else {
- $kernel->yield('die', CANT_WRONG => [$want, $heap->{want}]);
+ $kernel->yield('die', 'cant.stupid' => [$want, $heap->{want}]);
}
}
@@ -141,6 +145,8 @@
if ($method eq 'pass') {
$kernel->yield('want', 'AUTH:PASS');
+ } else {
+ $kernel->yield('die', 'auth', [$method]);
}
}
@@ -157,7 +163,7 @@
if ($pass eq $user->get('.password')) {
$kernel->yield('accept', $uid, $user);
} else {
- $kernel->yield('die', 'AUTH', [$uid]);
+ $kernel->yield('die', 'auth.pass', [$uid]);
}
}
@@ -167,7 +173,6 @@
my $cid = shift @$args;
my $cmd = shift @$args;
- return unless check_cid($cid);
$heap->{scope}{cid} = $cid;
$kernel->call($_[SESSION], "cmd_$cmd", $args);
delete $heap->{scope}{cid};
@@ -179,54 +184,40 @@
my $uid = shift @$args;
my $cmd = shift @$args;
- if (not $uid =~ /,/) {
- return unless check_uid($uid);
- } else {
- $uid = [split(/,/, $uid)];
- }
$heap->{scope}{uid} = $uid;
$kernel->call($_[SESSION], "cmd_$cmd", $args);
delete $heap->{scope}{uid};
}
-#> THIS(@rest)
-sub cmd_THIS {
+#> MARK($mark, @rest)
+sub cmd_MARK {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ my $mark = shift @$args;
my $cmd = shift @$args;
- return unless check_uid($heap->{uid});
- $heap->{scope}{uid} = $heap->{uid};
- $heap->{scope}{this} = 1;
+ $heap->{scope}{mark} = $mark;
$kernel->call($_[SESSION], "cmd_$cmd", $args);
- delete $heap->{scope}{uid};
- delete $heap->{scope}{this};
+ delete $heap->{scope}{mark};
}
#> MSG($type, @args)
sub cmd_MSG {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my @msg;
+ $heap->{user}->set(_last => time);
if ($heap->{scope}{cid}) {
- my $chan = $Registry->fetch('channel', $heap->{scope}{cid});
- my $users = $chan->list_ids('user');
- @msg = (
+ my $chan = check_cid($heap->{scope}{cid}) or return;
+ my $users = $chan->list_vals('user');
+ $kernel->post('Broadcaster', 'send', $users, [
'IN', $heap->{scope}{cid},
- 'OF', $heap->{uid}, 'MSG', @$args,
- );
- $kernel->post('Broadcaster', 'send', $users, [EMAIL PROTECTED]);
+ 'OF', $heap->{uid}, 'MSG', @$args]);
} elsif ($heap->{scope}{uid}) {
- if (not ref $heap->{scope}{uid}) {
- my $user = $Registry->fetch('user',
$heap->{scope}{uid});
- $user->put(['OF', $heap->{uid}, 'MSG', @$args]);
- } else {
- my @msg = ( 'OF', $heap->{uid}, 'MSG', @$args );
- $kernel->post('Broadcaster', 'send',
$heap->{scope}{uid}, [EMAIL PROTECTED]);
- }
+ my $user = check_uid($heap->{scope}{uid}) or return;
+ $user->put(['OF', $heap->{uid}, 'MSG', @$args]);
} else {
- return unless check_perm_access($heap->{user}, 'global msg');
- my $users = $Registry->list_ids('user');
- $kernel->post('Broadcaster', 'send', $users, ['OF',
$heap->{uid}, 'MSG', @$args]);
+ #return unless check_perm_access($heap->{user}, 'global msg');
+ #my $users = $Registry->list_vals('user');
+ #$kernel->post('Broadcaster', 'send', $users, ['OF',
$heap->{uid}, 'MSG', @$args]);
}
}
@@ -250,7 +241,8 @@
['IN', $cid, 'OF', $heap->{uid}, 'JOIN'],
);
} else {
- $kernel->yield('warn', ALREADY_JOINED => [$cid]);
+ # ERROR: insane.join You can't join a channel twice...
+ $kernel->yield('warn', 'insane.join' => [$cid]);
}
}
@@ -269,7 +261,8 @@
$chan->remove($user);
$user->remove($chan);
} else {
- $kernel->yield('warn', NOT_JOINED_PART => [$cid]);
+ # ERROR: insane.part You can't part a channel you're not in...
+ $kernel->yield('warn', 'insane.part' => [$cid]);
}
}
@@ -277,13 +270,22 @@
sub cmd_USERS {
my ($kernel, $heap) = @_[KERNEL, HEAP];
- # ERROR: NEED_IN
- $kernel->yield('die', NEED_IN => ['USERS']) unless $heap->{scope}{cid};
- my $chan = $Registry->fetch('channel', $heap->{scope}{cid});
+ my $chan = $Registry;
+ my @p = ();
+ if ($heap->{scope}{cid}) {
+ $chan = $Registry->fetch('channel', $heap->{scope}{cid});
+ @p = ('IN', $heap->{scope}{cid});
+ }
- $heap->{socket}->put(['IN', $heap->{scope}{cid}, 'USERS',
$chan->list_ids('user')]);
+ $heap->{socket}->put([EMAIL PROTECTED], 'USERS',
$chan->list_ids('user')]);
}
+sub cmd_CHANS {
+ my ($kernel, $heap) = @_[KERNEL, HEAP];
+
+ $heap->{socket}->put(['CHANS', $Registry->list_ids('channel')]);
+}
+
#> QUIT($why)
sub cmd_QUIT {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
@@ -291,82 +293,71 @@
$kernel->yield('shutdown', 'ACTIVE', @$args);
}
-my $PingTime = 60;
-#> PONG($time)
-sub cmd_PONG {
+#> INFO()
+sub cmd_INFO {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my $time = $args->[0];
- if (defined $heap->{ping_time}) {
- if ($time eq $heap->{ping_time}) {
- $kernel->alarm_remove($heap->{ping});
- $heap->{ping} = $kernel->alarm_set('send_ping',
- time + $PingTime + int(rand(5)));
- $heap->{ping_time} = undef;
- } else {
- $kernel->yield('bye', 'BAD PING');
- }
+ my ($targ, $chan);
+ my @in = ();
+ my @mark = ();
+
+ if ($heap->{scope}{mark}) {
+ @mark = ('MARK', $heap->{scope}{mark});
+ }
+
+ if ($heap->{scope}{cid}) {
+ $chan = check_cid($heap->{scope}{cid}) or return;
+ @in = ('IN', $chan->id);
} else {
- $kernel->yield('die', 'UNEXPECTED_PONG');
+ $chan = $Registry;
}
-}
-
-
-
-sub check_cmd_access {
- my ($user, $cmd, $in, %arg) = @_;
-
- unless ($user->may($cmd, %arg) or $user->may('*', %arg)) {
- $poe_kernel->yield('warn', ACCESS => [uc($cmd)], $in);
- return undef;
+ if ($heap->{scope}{uid} eq '*') {
+ my @users = $chan->list_vals('user');
+ foreach my $user (@users) {
+ my @info = map { ($_ => $user->get($_)) }
grep(/^[A-Z]/, $user->list_fields);
+ $heap->{user}->put([EMAIL PROTECTED], 'OF', $user->id,
@in, 'INFO', @info]);
+ }
+ } elsif ($heap->{scope}{uid}) {
+ my $user = check_uid($heap->{scope}{uid}) or return;
+ my @info = map { ($_ => $user->get($_)) } grep(/^[A-Z]/,
$user->list_fields);
+ $heap->{user}->put([EMAIL PROTECTED], 'OF', $user->id, @in,
'INFO', @info]);
}
-
- return 1;
}
-sub check_perm_access {
- my ($user, $cmd, $in, %arg) = @_;
- unless ($user->may($cmd, %arg) or $user->may('*', %arg)) {
- $poe_kernel->yield('warn', PERM => [$cmd], $in);
- return undef;
- }
-
- return 1;
-}
-
sub check_uid {
my $uid = shift;
my $in = shift;
+ # ERROR: syntax.id Badly formed identifier.
unless (defined $uid and
Haver::Server::Object::User->is_valid_id($uid)) {
- $poe_kernel->yield('warn', UID_INVALID => [$uid], $in);
+ $poe_kernel->yield('warn', 'syntax.id.user' => [$uid], $in);
return undef;
}
unless ($uid eq '.' or $Registry->contains('user', $uid)) {
- $poe_kernel->yield('warn', UID_NOT_FOUND => [$uid], $in);
+ $poe_kernel->yield('warn', 'notfound.user' => [$uid], $in);
return undef;
}
- return 1;
+ return $Registry->fetch('user', $uid);
}
sub check_cid {
my $cid = shift;
unless (defined $cid and
Haver::Server::Object::Channel->is_valid_id($cid)) {
- $poe_kernel->yield('warn', CID_INVALID => [$cid]);
+ $poe_kernel->yield('warn', 'syntax.id.channel' => [$cid]);
return undef;
}
unless ($Registry->contains('channel', $cid)) {
- $poe_kernel->yield('warn', CID_NOT_FOUND => [$cid]);
+ $poe_kernel->yield('warn', 'notfound.channel' => [$cid]);
return undef;
}
- return 1;
+ return $Registry->fetch('channel', $cid);
}
1;
Modified: trunk/main/server/lib/Haver/Server/POE/Connection.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE/Connection.pm 2004-07-23
06:11:30 UTC (rev 324)
+++ trunk/main/server/lib/Haver/Server/POE/Connection.pm 2004-07-23
06:13:23 UTC (rev 325)
@@ -268,8 +268,8 @@
$kernel->post('Broadcaster', 'send', [ keys %users ],
$msg);
}
if ($user) {
- ($heap->{port}, $heap->{address}) = $user->get('.port',
'.address');
- $user->save if $user->has('reg');
+ ($heap->{port}, $heap->{address}) = $user->get('_port',
'_address');
+ $user->save if $user->has('_reg');
}
} else {
$kernel->post('Logger', 'error', "Trying to run cleanup more
than once! @args");
@@ -317,16 +317,22 @@
$heap->{user} = $user;
$heap->{uid} = $uid;
my $addr = join('.', (split(/\./, $heap->{want_data}{address}))[0,1,2])
. '.*';
+ my $login_time = time;
$user->set(
- address => $addr,
- '.address' => delete $heap->{want_data}{address},
- '.port' => delete $heap->{want_data}{port},
+ IP => $addr,
+ Login => sub {
+ time - $login_time;
+ },
+ _last => time,
+ Idle => sub {
+ my ($u) = @_;
+ time - $u->get('_last');
+ },
+ '.IP' => $heap->{want_data}{address},
+ _address => delete $heap->{want_data}{address},
+ _port => delete $heap->{want_data}{port},
);
delete $heap->{want_data};
- $user->set_flags('address', 'li');
- $user->set_flags('.address', 'l');
- $user->set_flags('.port', 'l');
-
$heap->{login} = 1;
$heap->{socket}->put(['ACCEPT', $uid]);
}
Modified: trunk/main/server/lib/Haver/Server/POE.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE.pm 2004-07-23 06:11:30 UTC (rev
324)
+++ trunk/main/server/lib/Haver/Server/POE.pm 2004-07-23 06:13:23 UTC (rev
325)
@@ -59,6 +59,7 @@
attic
basement
kitchen
+ Creatures
)],
);
