Net/XMPP2/SimpleConnection.pm

package Net::XMPP2::SimpleConnection;
use strict;

use IO::Socket::INET;
use Errno;
use Fcntl;
use Encode;
use Net::SSLeay;
use IO::Handle;

BEGIN {
   Net::SSLeay::load_error_strings ();
   Net::SSLeay::SSLeay_add_ssl_algorithms ();
   Net::SSLeay::randomize ();
}

=head1 NAME

Net::XMPP2::SimpleConnection - A low level TCP/TLS connection

=head1 SYNOPSIS

   package foo;
   use Net::XMPP2::SimpleConnection;

   our @ISA = qw/Net::XMPP2::SimpleConnection/;

=head1 DESCRIPTION

This module only implements the basic low level socket and SSL handling stuff.
It is used by L<Net::XMPP2::Connection> and you shouldn't mess with it :-)

(NOTE: This is the part of Net::XMPP2 which I feel least confident about :-)

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   my $self = { disconnect_cb => sub {}, @_ };
   bless $self, $class;
   return $self;
}

sub set_block {
   my ($self) = @_;
   my $flags = 0;
   fcntl($self->{socket}, F_GETFL, $flags)
       or die "Couldn't get flags for HANDLE : $!\n";
   $flags &= ~O_NONBLOCK;
   fcntl($self->{socket}, F_SETFL, $flags)
       or die "Couldn't set flags for HANDLE: $!\n";
}

sub set_noblock {
   my ($self) = @_;
   my $flags = 0;
   fcntl($self->{socket}, F_GETFL, $flags)
       or die "Couldn't get flags for HANDLE : $!\n";
   $flags |= O_NONBLOCK;
   fcntl($self->{socket}, F_SETFL, $flags)
       or die "Couldn't set flags for HANDLE: $!\n";
}

sub connect {
   my ($self, $host, $port) = @_;

   $self->{socket}
      and return 1;

   my $sock = IO::Socket::INET->new (
      PeerAddr => $host,
      PeerPort => $port,
      Proto    => 'tcp',
      Blocking => 1
   );
   return undef unless $sock;;

   $self->{socket} = $sock;
   $self->{host}   = $host;
   $self->{port}   = $port;

   $self->set_noblock;

   binmode $sock, ":raw";

   $self->{r} =
      AnyEvent->io (poll => 'r', fh => $sock, cb => sub {
         my $l = sysread $sock, my $data, 1024;

         if ($l) {
            $self->{read_buffer} .= decode_utf8 $data;
            $self->handle_data (\$self->{read_buffer});

         } else {
            return if $! == Errno::EAGAIN;
            if (defined $l) {
               $self->disconnect ("EOF from server '$self->{host}:$self->{port}'");
               return;

            } else {
               $self->disconnect ("Error while reading from server '$self->{host}:$port': $!");
               return;
            }
         }
      });
   return 1;
}

sub end_sockets {
   my ($self) = @_;
   delete $self->{r};
   delete $self->{w};
   if (delete $self->{ssl_enabled}) {
      Net::SSLeay::free ($self->{ssl});
      delete $self->{ssl};
      Net::SSLeay::CTX_free ($self->{ctx});
      delete $self->{ctx};
   }
   close ($self->{socket});
   delete $self->{socket};
}

sub try_ssl_write {
   my ($self) = @_;

   my $l = Net::SSLeay::write ($self->{ssl}, $self->{write_buffer});

   if ($l <= 0) {
      if ($l == 0) {
         $self->disconnect ("unexpected EOF from server (ssl) '$self->{host}:$self->{port}'");
         return;

      } else {
         my $err2 = Net::SSLeay::get_error $self->{ssl}, $l;
         if ($err2 == 2 || $err2 == 3) {
            delete $self->{w};
            $self->make_ssl_write_watcher ($err2 == 2 ? 'r' : 'w');
            return;
         }

         if ($! != Errno::EAGAIN
             or my $err = Net::SSLeay::ERR_get_error) {

            $self->disconnect (
               sprintf (
                  "Error while writing from server '$self->{host}:$self->{port}': (%d|%s|%s)",
               $err2, (Net::SSLeay::ERR_error_string $err), "$!")
            );
            return;
         }
      }
   } else {
      $self->debug_wrote_data (substr $self->{write_buffer}, 0, $l);
      $self->{write_buffer} = substr $self->{write_buffer}, $l;
      if (length ($self->{write_buffer}) <= 0) {
         delete $self->{w};
      }
   }
}

sub try_ssl_read {
   my ($self) = @_;
   my $r = Net::SSLeay::read ($self->{ssl});

   if (defined $r) {
      if ($r eq '') {
         if (my $err = Net::SSLeay::ERR_get_error) {
            $self->disconnect (
               sprintf (
                  "Error while reading from server '$self->{host}:$self->{port}':"
                  ."(%s|%s)",
                  (Net::SSLeay::ERR_error_string $err), "$!")
            );
            return;
         }
         # is this right? $r = '' => EOF? sucky Net::SSLeay... arg...
         $self->disconnect ("EOF from server '$self->{host}:$self->{port}'.");
         return;
      }

      $self->{read_buffer} .= decode_utf8 ($r);
      $self->handle_data (\$self->{read_buffer});
   } else {
      my $err2 = Net::SSLeay::get_error $self->{ssl}, $r;
      if ($err2 == 2 || $err2 == 3) {
         #d# warn "READ RETRY $err2\n";
         delete $self->{r};
         $self->make_ssl_read_watcher ($err2 == 2 ? 'r' : 'w');
         return;
      }

      if ($! != Errno::EAGAIN
          or my $err = Net::SSLeay::ERR_get_error) {

         $self->disconnect (
            sprintf (
               "Error while reading from server '$self->{host}:$self->{port}':"
               ."(%d|%s|%s)",
               $err2, (Net::SSLeay::ERR_error_string $err), "$!")
         );
         return;
      }
   }
}

sub write_data {
   my ($self, $data) = @_;
   #return unless $self->{r};

   my $cl = $self->{socket};
   $self->{write_buffer} .= encode_utf8 ($data);

   unless ($self->{w}) {
      $self->{w} =
         AnyEvent->io (poll => 'w', fh => $cl, cb => sub {
            if (not $self->{ssl_enabled}) {
               if (my $data = $self->{write_buffer}) {
                  my $len = syswrite $cl, $data;
                  unless ($len) {
                     return if $! == Errno::EAGAIN;
                     if (not defined $len) {
                        warn "error when writing data on $self->{host}:$self->{port}: $!";
                        return;
                     } else {
                        delete $self->{w};
                     }
                  }

                  if ($len == length $self->{write_buffer}) {
                     delete $self->{w};
                  }

                  $self->debug_wrote_data (substr $self->{write_buffer}, 0, $len);
                  $self->{write_buffer} = substr $self->{write_buffer}, $len;
               }
            } else {
               $self->try_ssl_write;
            }
         });
   }
}

sub make_ssl_read_watcher {
   my ($self, $poll) = @_;
   return if $self->{r};

   $poll ||= 'r';
   $self->{r} =
      AnyEvent->io (poll => $poll, fh => $self->{socket}, cb => sub {
         $self->try_ssl_read;
      });
}

sub make_ssl_write_watcher {
   my ($self, $poll) = @_;
   return if $self->{w};

   $poll ||= 'w';
   $self->{w} =
      AnyEvent->io (poll => $poll, fh => $self->{socket}, cb => sub {
         $self->try_ssl_write;
      });
}

sub enable_ssl {
   my ($self) = @_;

   $Net::SSLeay::ssl_version = 10; # Insist on TLSv1

   $self->{ssl_enabled} = 1;

   #d# warn "START TLS!\n";

   $self->{r} = undef;
   $self->{w} = undef;

   $self->{ctx} = Net::SSLeay::CTX_new ();

   # enable SSL_MODE_ENABLE_PARTIAL_WRITE and SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER
   Net::SSLeay::CTX_set_mode($self->{ctx}, 1 | 2);

   $self->{ssl} = Net::SSLeay::new ($self->{ctx});

   Net::SSLeay::set_fd ($self->{ssl}, fileno $self->{socket});
   #d# warn "CONNECT\n";
   Net::SSLeay::connect $self->{ssl};
   #d# warn "CONNECT END\n";
   binmode $self->{socket}, ":bytes";

   $self->{ssl_read_data} = "";
   $self->make_ssl_read_watcher;
}

sub disconnect {
   my ($self, $msg) = @_;
   $self->end_sockets;
   $self->{disconnect_cb}->($self->{host}, $self->{port}, $msg);
}

1;
Revision:	1.8
Committed:	Wed Jul 4 16:05:22 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.7:	+3 -1 lines
Log Message:	major documentation refresh. preparing for release
#	Content
1	package Net::XMPP2::SimpleConnection;
2	use strict;
3
4	use IO::Socket::INET;
5	use Errno;
6	use Fcntl;
7	use Encode;
8	use Net::SSLeay;
9	use IO::Handle;
10
11	BEGIN {
12	Net::SSLeay::load_error_strings ();
13	Net::SSLeay::SSLeay_add_ssl_algorithms ();
14	Net::SSLeay::randomize ();
15	}
16
17	=head1 NAME
18
19	Net::XMPP2::SimpleConnection - A low level TCP/TLS connection
20
21	=head1 SYNOPSIS
22
23	package foo;
24	use Net::XMPP2::SimpleConnection;
25
26	our @ISA = qw/Net::XMPP2::SimpleConnection/;
27
28	=head1 DESCRIPTION
29
30	This module only implements the basic low level socket and SSL handling stuff.
31	It is used by L<Net::XMPP2::Connection> and you shouldn't mess with it :-)
32
33	(NOTE: This is the part of Net::XMPP2 which I feel least confident about :-)
34
35	=cut
36
37	sub new {
38	my $this = shift;
39	my $class = ref($this) \|\| $this;
40	my $self = { disconnect_cb => sub {}, @_ };
41	bless $self, $class;
42	return $self;
43	}
44
45	sub set_block {
46	my ($self) = @_;
47	my $flags = 0;
48	fcntl($self->{socket}, F_GETFL, $flags)
49	or die "Couldn't get flags for HANDLE : $!\n";
50	$flags &= ~O_NONBLOCK;
51	fcntl($self->{socket}, F_SETFL, $flags)
52	or die "Couldn't set flags for HANDLE: $!\n";
53	}
54
55	sub set_noblock {
56	my ($self) = @_;
57	my $flags = 0;
58	fcntl($self->{socket}, F_GETFL, $flags)
59	or die "Couldn't get flags for HANDLE : $!\n";
60	$flags \|= O_NONBLOCK;
61	fcntl($self->{socket}, F_SETFL, $flags)
62	or die "Couldn't set flags for HANDLE: $!\n";
63	}
64
65	sub connect {
66	my ($self, $host, $port) = @_;
67
68	$self->{socket}
69	and return 1;
70
71	my $sock = IO::Socket::INET->new (
72	PeerAddr => $host,
73	PeerPort => $port,
74	Proto => 'tcp',
75	Blocking => 1
76	);
77	return undef unless $sock;;
78
79	$self->{socket} = $sock;
80	$self->{host} = $host;
81	$self->{port} = $port;
82
83	$self->set_noblock;
84
85	binmode $sock, ":raw";
86
87	$self->{r} =
88	AnyEvent->io (poll => 'r', fh => $sock, cb => sub {
89	my $l = sysread $sock, my $data, 1024;
90
91	if ($l) {
92	$self->{read_buffer} .= decode_utf8 $data;
93	$self->handle_data (\$self->{read_buffer});
94
95	} else {
96	return if $! == Errno::EAGAIN;
97	if (defined $l) {
98	$self->disconnect ("EOF from server '$self->{host}:$self->{port}'");
99	return;
100
101	} else {
102	$self->disconnect ("Error while reading from server '$self->{host}:$port': $!");
103	return;
104	}
105	}
106	});
107	return 1;
108	}
109
110	sub end_sockets {
111	my ($self) = @_;
112	delete $self->{r};
113	delete $self->{w};
114	if (delete $self->{ssl_enabled}) {
115	Net::SSLeay::free ($self->{ssl});
116	delete $self->{ssl};
117	Net::SSLeay::CTX_free ($self->{ctx});
118	delete $self->{ctx};
119	}
120	close ($self->{socket});
121	delete $self->{socket};
122	}
123
124	sub try_ssl_write {
125	my ($self) = @_;
126
127	my $l = Net::SSLeay::write ($self->{ssl}, $self->{write_buffer});
128
129	if ($l <= 0) {
130	if ($l == 0) {
131	$self->disconnect ("unexpected EOF from server (ssl) '$self->{host}:$self->{port}'");
132	return;
133
134	} else {
135	my $err2 = Net::SSLeay::get_error $self->{ssl}, $l;
136	if ($err2 == 2 \|\| $err2 == 3) {
137	delete $self->{w};
138	$self->make_ssl_write_watcher ($err2 == 2 ? 'r' : 'w');
139	return;
140	}
141
142	if ($! != Errno::EAGAIN
143	or my $err = Net::SSLeay::ERR_get_error) {
144
145	$self->disconnect (
146	sprintf (
147	"Error while writing from server '$self->{host}:$self->{port}': (%d\|%s\|%s)",
148	$err2, (Net::SSLeay::ERR_error_string $err), "$!")
149	);
150	return;
151	}
152	}
153	} else {
154	$self->debug_wrote_data (substr $self->{write_buffer}, 0, $l);
155	$self->{write_buffer} = substr $self->{write_buffer}, $l;
156	if (length ($self->{write_buffer}) <= 0) {
157	delete $self->{w};
158	}
159	}
160	}
161
162	sub try_ssl_read {
163	my ($self) = @_;
164	my $r = Net::SSLeay::read ($self->{ssl});
165
166	if (defined $r) {
167	if ($r eq '') {
168	if (my $err = Net::SSLeay::ERR_get_error) {
169	$self->disconnect (
170	sprintf (
171	"Error while reading from server '$self->{host}:$self->{port}':"
172	."(%s\|%s)",
173	(Net::SSLeay::ERR_error_string $err), "$!")
174	);
175	return;
176	}
177	# is this right? $r = '' => EOF? sucky Net::SSLeay... arg...
178	$self->disconnect ("EOF from server '$self->{host}:$self->{port}'.");
179	return;
180	}
181
182	$self->{read_buffer} .= decode_utf8 ($r);
183	$self->handle_data (\$self->{read_buffer});
184	} else {
185	my $err2 = Net::SSLeay::get_error $self->{ssl}, $r;
186	if ($err2 == 2 \|\| $err2 == 3) {
187	#d# warn "READ RETRY $err2\n";
188	delete $self->{r};
189	$self->make_ssl_read_watcher ($err2 == 2 ? 'r' : 'w');
190	return;
191	}
192
193	if ($! != Errno::EAGAIN
194	or my $err = Net::SSLeay::ERR_get_error) {
195
196	$self->disconnect (
197	sprintf (
198	"Error while reading from server '$self->{host}:$self->{port}':"
199	."(%d\|%s\|%s)",
200	$err2, (Net::SSLeay::ERR_error_string $err), "$!")
201	);
202	return;
203	}
204	}
205	}
206
207	sub write_data {
208	my ($self, $data) = @_;
209	#return unless $self->{r};
210
211	my $cl = $self->{socket};
212	$self->{write_buffer} .= encode_utf8 ($data);
213
214	unless ($self->{w}) {
215	$self->{w} =
216	AnyEvent->io (poll => 'w', fh => $cl, cb => sub {
217	if (not $self->{ssl_enabled}) {
218	if (my $data = $self->{write_buffer}) {
219	my $len = syswrite $cl, $data;
220	unless ($len) {
221	return if $! == Errno::EAGAIN;
222	if (not defined $len) {
223	warn "error when writing data on $self->{host}:$self->{port}: $!";
224	return;
225	} else {
226	delete $self->{w};
227	}
228	}
229
230	if ($len == length $self->{write_buffer}) {
231	delete $self->{w};
232	}
233
234	$self->debug_wrote_data (substr $self->{write_buffer}, 0, $len);
235	$self->{write_buffer} = substr $self->{write_buffer}, $len;
236	}
237	} else {
238	$self->try_ssl_write;
239	}
240	});
241	}
242	}
243
244	sub make_ssl_read_watcher {
245	my ($self, $poll) = @_;
246	return if $self->{r};
247
248	$poll \|\|= 'r';
249	$self->{r} =
250	AnyEvent->io (poll => $poll, fh => $self->{socket}, cb => sub {
251	$self->try_ssl_read;
252	});
253	}
254
255	sub make_ssl_write_watcher {
256	my ($self, $poll) = @_;
257	return if $self->{w};
258
259	$poll \|\|= 'w';
260	$self->{w} =
261	AnyEvent->io (poll => $poll, fh => $self->{socket}, cb => sub {
262	$self->try_ssl_write;
263	});
264	}
265
266	sub enable_ssl {
267	my ($self) = @_;
268
269	$Net::SSLeay::ssl_version = 10; # Insist on TLSv1
270
271	$self->{ssl_enabled} = 1;
272
273	#d# warn "START TLS!\n";
274
275	$self->{r} = undef;
276	$self->{w} = undef;
277
278	$self->{ctx} = Net::SSLeay::CTX_new ();
279
280	# enable SSL_MODE_ENABLE_PARTIAL_WRITE and SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER
281	Net::SSLeay::CTX_set_mode($self->{ctx}, 1 \| 2);
282
283	$self->{ssl} = Net::SSLeay::new ($self->{ctx});
284
285	Net::SSLeay::set_fd ($self->{ssl}, fileno $self->{socket});
286	#d# warn "CONNECT\n";
287	Net::SSLeay::connect $self->{ssl};
288	#d# warn "CONNECT END\n";
289	binmode $self->{socket}, ":bytes";
290
291	$self->{ssl_read_data} = "";
292	$self->make_ssl_read_watcher;
293	}
294
295	sub disconnect {
296	my ($self, $msg) = @_;
297	$self->end_sockets;
298	$self->{disconnect_cb}->($self->{host}, $self->{port}, $msg);
299	}
300
301	1;