[ViewVC] Annotation of: cvs/cvsroot/Net-IRC3/samples/jsonsrv

#!/usr/bin/perl
use strict;
use URI;
use AnyEvent::Impl::Perl;
use JSON::Syck;
use JSONConnection;
use Net::IRC3::Client::Connection;
$Net::IRC3::Client::Connection::DEBUG = 1;

our $CFG;
our %ALIASES;
our %CONNS;

our $JS;

sub load_cfg {
   $CFG ||= {};
   return unless -e "$ENV{HOME}/.jsonircrc";
   open CFGH, "<", "$ENV{HOME}/.jsonircrc" or die "Couldn't open ~/.jsonircrc: $!";
   $::CFG = JSON::Syck::Load (do { local $/; <CFGH> });
}

sub save_cfg {
   open CFGH, ">", "$ENV{HOME}/.jsonircrc" or die "Couldn't open for writing ~/.jsonircrc: $!";
   print CFGH (JSON::Syck::Dump ($::CFG));
   close CFGH;
}

sub to_dest_id {
   my ($irccon, $targ) = @_;
   $irccon = $ALIASES{$irccon} || $irccon;
   my $uri = new URI;
   $uri->scheme ("jsirc"); $uri->authority ($irccon); $uri->path ($targ);
   "$uri"
}

sub unalias {
   my ($id) = @_;
   for (keys %ALIASES) {
      if ($id eq $ALIASES{$_}) {
         return $_;
      }
   }
}

sub lookup_connection {
   my ($id) = @_;
   my $alias = unalias ($id);
   return $CONNS{$alias || $id}
}

sub from_dest_id {
   my ($dest_id) = @_;
   my $uri = URI->new ($dest_id);
   my $path = ($uri->path_segments ())[1];
   return (lookup_connection ($uri->authority), unalias ($uri->authority) || $uri->authority, $path);
}

sub connect_irc {
   my ($host, $port, $alias) = @_;
   my $irccon = "$host:$port";
   my $pc = $CONNS{$irccon} = Net::IRC3::Client::Connection->new;
   $ALIASES{$irccon} = $alias if defined $alias;

   $pc->reg_cb (
      channel_add => sub {
         my ($pc, $chan, @nicks) = @_;
         my $dest = to_dest_id ($irccon, $chan);
         my @ids  = map { to_dest_id ($irccon, $_) } @nicks;
         $JS->broadcast ({
            src  => $dest,
            type => 'metainfo',
            info_type => 'add_ids',
            ids => \@ids,
            timestamp => time (),
         });
         1;
      },
      channel_remove => sub {
         my ($pc, $chan, @nicks) = @_;
         my $dest = to_dest_id ($irccon, $chan);
         my @ids  = map { to_dest_id ($irccon, $_) } @nicks;
         $JS->broadcast ({
            src  => $dest,
            type => 'metainfo',
            info_type => 'remove_ids',
            ids => \@ids,
            timestamp => time (),
         });
         1;
      },
      publicmsg => sub {
         my ($pc, $chan, $msg) = @_;
         my ($nick)   = Net::IRC3::Util::split_prefix ($msg->{prefix});
         my $dest     = to_dest_id ($irccon, $chan);
         my $nickdest = to_dest_id ($irccon, $nick);

         $JS->broadcast ({
            src => $dest,
            type => "message",
            msg_type => "public",
            message => $msg->{trailing},
            timestamp => time (),
            to   => { nick => $pc->nick, id => to_dest_id ($irccon, $pc->nick) },
            from => { nick => $nick,     id => $nickdest },
         });
         1;
      },
      privatemsg => sub {
         my ($pc, $dsgnick, $msg) = @_;
         my ($nick) = Net::IRC3::Util::split_prefix ($msg->{prefix});
         my $dest   = to_dest_id ($irccon, $nick);

         $JS->broadcast ({
            src => $dest,
            type => "message",
            msg_type => "private",
            message => $msg->{trailing},
            timestamp => time (),
            to   => { nick => $pc->nick, id => to_dest_id ($irccon, $pc->nick) },
            from => { nick => $nick,     id => $dest },
         });
         1;
      },
      connect => sub {
         info_reply ($JS, undef, undef,
            "Connected to $host:$port "
               . (defined $alias ? "(aka $alias)" : "")
         );
      },
      disconnect => sub {
         error_reply ($JS, undef, undef,
            "Lost connection to $host:$port " 
               . (defined $alias ? "(aka $alias)" : "")
         );
         delete $CONNS{"$host:$port"};
         delete $ALIASES{"$host:$port"};
      }
   );

   eval {
      $pc->connect ($host, $port);
   };
   if ($@) {
      error_reply ($JS, undef, undef,
         "Couldn't connect to $host:$port "
         . (defined $alias ? "(aka $alias)" : "")
         . ": $@"
      );
      delete $CONNS{"$host:$port"};
      delete $ALIASES{"$host:$port"};
      return;
   }
   $pc->register (qw/elmex2 elmex2 elmex2/);

   for (@{$CFG->{channels}->{$alias || "$host:$port"}}) {
      $pc->send_srv (JOIN => undef => $_);
   }
}

sub update_connections {
   for (map { /^(\S+):(\d+)/ ? [$1, $2, $_] : [] } keys %CONNS) {
      my ($h, $p) = @$_;
      unless (
         grep {
            ($_->{host} eq $h) && (($_->{port} || 6667) == $p) && ($_->{connect})
         } @{$CFG->{servers}})
      {
         $CONNS{$_->[2]}->disconnect;
      }
   }

   for my $con (@{$CFG->{servers}}) {
      my ($host, $port) = ($con->{host}, $con->{port} || 6667);

      if ($con->{connect} and not $CONNS{"$host:$port"}) {
         connect_irc ($host, $port, $con->{alias});
      }
   }
}

sub info_reply {
   my ($con, $lid, $infodata, $string) = @_;
   if (defined $lid) {
      $con->send_data ($lid,
         { type => 'info', info_packet => $infodata, message => $string });
   } else {
      $JS->broadcast ({ type => 'info', info_packet => $infodata, message => $string });
   }
}

sub error_reply {
   my ($con, $lid, $errdata, $string) = @_;
   if (defined $lid) {
      $con->send_data ($lid,
         { type => 'error', error_packet => $errdata, message => $string });
   } else {
      $JS->broadcast ({ type => 'error', error_packet => $errdata, message => $string });
   }
}

load_cfg;

my $c = AnyEvent->condvar;

$JS =
   JSONConnection->new (
      packet_cb => sub {
         my ($JS, $lid, $data) = @_;

         if ($data->{type} eq 'message') {
            my ($con, $irccon, $dest) = from_dest_id ($data->{dest});
            unless (defined $con) {
               error_reply ($JS, $lid, $data, "No such ID found: '$data->{dest}'");
               return
            }
            $con->send_srv (PRIVMSG => $data->{message} => $dest);

         } elsif ($data->{type} eq 'command') {
            if ($data->{command} eq 'reload') {
               load_cfg;
               update_connections;
            } elsif ($data->{command} eq 'list_connections') {
            } elsif ($data->{command} eq 'list_ids') {
            }
         } else {
            error_reply ($JS, $lid, $data, "Did not understand this packet");
         }
         1
      },
      connect_cb => sub {
         my ($JS, $lid) = @_;
         $JS->send_data ($lid, { type => "hello" });
      });

update_connections;

$JS->start_listener;

$c->wait;
Revision:	1.6
Committed:	Mon Jan 15 17:41:42 2007 UTC (19 years, 9 months ago) by elmex
Branch:	MAIN
Changes since 1.5:	+26 -0 lines
Log Message:	just a minor change on the json chat
#	User	Rev	Content
1	elmex	1.1	#!/usr/bin/perl
2			use strict;
3	elmex	1.5	use URI;
4	elmex	1.1	use AnyEvent::Impl::Perl;
5			use JSON::Syck;
6			use JSONConnection;
7			use Net::IRC3::Client::Connection;
8			$Net::IRC3::Client::Connection::DEBUG = 1;
9
10			our $CFG;
11	elmex	1.5	our %ALIASES;
12	elmex	1.1	our %CONNS;
13
14	elmex	1.5	our $JS;
15
16	elmex	1.1	sub load_cfg {
17			$CFG \|\|= {};
18			return unless -e "$ENV{HOME}/.jsonircrc";
19			open CFGH, "<", "$ENV{HOME}/.jsonircrc" or die "Couldn't open ~/.jsonircrc: $!";
20			$::CFG = JSON::Syck::Load (do { local $/; <CFGH> });
21			}
22
23			sub save_cfg {
24			open CFGH, ">", "$ENV{HOME}/.jsonircrc" or die "Couldn't open for writing ~/.jsonircrc: $!";
25			print CFGH (JSON::Syck::Dump ($::CFG));
26			close CFGH;
27			}
28
29	elmex	1.3	sub to_dest_id {
30	elmex	1.5	my ($irccon, $targ) = @_;
31			$irccon = $ALIASES{$irccon} \|\| $irccon;
32			my $uri = new URI;
33			$uri->scheme ("jsirc"); $uri->authority ($irccon); $uri->path ($targ);
34			"$uri"
35	elmex	1.3	}
36	elmex	1.5
37			sub unalias {
38			my ($id) = @_;
39			for (keys %ALIASES) {
40			if ($id eq $ALIASES{$_}) {
41			return $_;
42			}
43	elmex	1.3	}
44			}
45
46	elmex	1.5	sub lookup_connection {
47			my ($id) = @_;
48			my $alias = unalias ($id);
49			return $CONNS{$alias \|\| $id}
50			}
51	elmex	1.3
52	elmex	1.5	sub from_dest_id {
53			my ($dest_id) = @_;
54			my $uri = URI->new ($dest_id);
55			my $path = ($uri->path_segments ())[1];
56			return (lookup_connection ($uri->authority), unalias ($uri->authority) \|\| $uri->authority, $path);
57			}
58	elmex	1.1
59	elmex	1.5	sub connect_irc {
60			my ($host, $port, $alias) = @_;
61			my $irccon = "$host:$port";
62			my $pc = $CONNS{$irccon} = Net::IRC3::Client::Connection->new;
63			$ALIASES{$irccon} = $alias if defined $alias;
64	elmex	1.1
65			$pc->reg_cb (
66	elmex	1.6	channel_add => sub {
67			my ($pc, $chan, @nicks) = @_;
68			my $dest = to_dest_id ($irccon, $chan);
69			my @ids = map { to_dest_id ($irccon, $_) } @nicks;
70			$JS->broadcast ({
71			src => $dest,
72			type => 'metainfo',
73			info_type => 'add_ids',
74			ids => \@ids,
75			timestamp => time (),
76			});
77			1;
78			},
79			channel_remove => sub {
80			my ($pc, $chan, @nicks) = @_;
81			my $dest = to_dest_id ($irccon, $chan);
82			my @ids = map { to_dest_id ($irccon, $_) } @nicks;
83			$JS->broadcast ({
84			src => $dest,
85			type => 'metainfo',
86			info_type => 'remove_ids',
87			ids => \@ids,
88			timestamp => time (),
89			});
90			1;
91			},
92	elmex	1.1	publicmsg => sub {
93			my ($pc, $chan, $msg) = @_;
94	elmex	1.5	my ($nick) = Net::IRC3::Util::split_prefix ($msg->{prefix});
95			my $dest = to_dest_id ($irccon, $chan);
96			my $nickdest = to_dest_id ($irccon, $nick);
97
98			$JS->broadcast ({
99	elmex	1.3	src => $dest,
100			type => "message",
101			msg_type => "public",
102	elmex	1.1	message => $msg->{trailing},
103	elmex	1.2	timestamp => time (),
104	elmex	1.5	to => { nick => $pc->nick, id => to_dest_id ($irccon, $pc->nick) },
105	elmex	1.4	from => { nick => $nick, id => $nickdest },
106	elmex	1.1	});
107			1;
108			},
109			privatemsg => sub {
110			my ($pc, $dsgnick, $msg) = @_;
111			my ($nick) = Net::IRC3::Util::split_prefix ($msg->{prefix});
112	elmex	1.5	my $dest = to_dest_id ($irccon, $nick);
113
114			$JS->broadcast ({
115	elmex	1.3	src => $dest,
116			type => "message",
117			msg_type => "private",
118	elmex	1.1	message => $msg->{trailing},
119	elmex	1.2	timestamp => time (),
120	elmex	1.5	to => { nick => $pc->nick, id => to_dest_id ($irccon, $pc->nick) },
121	elmex	1.4	from => { nick => $nick, id => $dest },
122	elmex	1.1	});
123			1;
124			},
125	elmex	1.5	connect => sub {
126			info_reply ($JS, undef, undef,
127			"Connected to $host:$port "
128			. (defined $alias ? "(aka $alias)" : "")
129			);
130			},
131			disconnect => sub {
132			error_reply ($JS, undef, undef,
133			"Lost connection to $host:$port "
134			. (defined $alias ? "(aka $alias)" : "")
135			);
136			delete $CONNS{"$host:$port"};
137			delete $ALIASES{"$host:$port"};
138			}
139	elmex	1.1	);
140
141	elmex	1.5	eval {
142			$pc->connect ($host, $port);
143			};
144			if ($@) {
145			error_reply ($JS, undef, undef,
146			"Couldn't connect to $host:$port "
147			. (defined $alias ? "(aka $alias)" : "")
148			. ": $@"
149			);
150			delete $CONNS{"$host:$port"};
151			delete $ALIASES{"$host:$port"};
152			return;
153			}
154	elmex	1.1	$pc->register (qw/elmex2 elmex2 elmex2/);
155
156	elmex	1.5	for (@{$CFG->{channels}->{$alias \|\| "$host:$port"}}) {
157			$pc->send_srv (JOIN => undef => $_);
158	elmex	1.1	}
159			}
160
161	elmex	1.5	sub update_connections {
162			for (map { /^(\S+):(\d+)/ ? [$1, $2, $_] : [] } keys %CONNS) {
163			my ($h, $p) = @$_;
164			unless (
165			grep {
166			($_->{host} eq $h) && (($_->{port} \|\| 6667) == $p) && ($_->{connect})
167			} @{$CFG->{servers}})
168			{
169			$CONNS{$_->[2]}->disconnect;
170			}
171			}
172
173			for my $con (@{$CFG->{servers}}) {
174			my ($host, $port) = ($con->{host}, $con->{port} \|\| 6667);
175
176			if ($con->{connect} and not $CONNS{"$host:$port"}) {
177			connect_irc ($host, $port, $con->{alias});
178			}
179			}
180			}
181
182			sub info_reply {
183			my ($con, $lid, $infodata, $string) = @_;
184			if (defined $lid) {
185			$con->send_data ($lid,
186			{ type => 'info', info_packet => $infodata, message => $string });
187			} else {
188			$JS->broadcast ({ type => 'info', info_packet => $infodata, message => $string });
189			}
190			}
191
192			sub error_reply {
193			my ($con, $lid, $errdata, $string) = @_;
194			if (defined $lid) {
195			$con->send_data ($lid,
196			{ type => 'error', error_packet => $errdata, message => $string });
197			} else {
198			$JS->broadcast ({ type => 'error', error_packet => $errdata, message => $string });
199			}
200			}
201
202			load_cfg;
203
204			my $c = AnyEvent->condvar;
205
206			$JS =
207			JSONConnection->new (
208			packet_cb => sub {
209			my ($JS, $lid, $data) = @_;
210
211			if ($data->{type} eq 'message') {
212			my ($con, $irccon, $dest) = from_dest_id ($data->{dest});
213			unless (defined $con) {
214			error_reply ($JS, $lid, $data, "No such ID found: '$data->{dest}'");
215			return
216			}
217			$con->send_srv (PRIVMSG => $data->{message} => $dest);
218
219			} elsif ($data->{type} eq 'command') {
220			if ($data->{command} eq 'reload') {
221			load_cfg;
222			update_connections;
223			} elsif ($data->{command} eq 'list_connections') {
224			} elsif ($data->{command} eq 'list_ids') {
225			}
226			} else {
227			error_reply ($JS, $lid, $data, "Did not understand this packet");
228			}
229			1
230			},
231			connect_cb => sub {
232			my ($JS, $lid) = @_;
233			$JS->send_data ($lid, { type => "hello" });
234			});
235
236			update_connections;
237
238			$JS->start_listener;
239	elmex	1.1
240			$c->wait;