Net/XMPP2/SimpleConnection.pm

package Net::XMPP2::SimpleConnection;
use IO::Socket::INET;
use Errno;
use Fcntl;
use Encode;
use Net::SSLeay;

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>.

=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, ":utf8";

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

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

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

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

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

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

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

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

      } else {
         my $err2 = Net::SSLeay::get_error $self->{ssl}, $l;
         if ($err2 == 2 || $err2 == 3) {
            warn "WRITE RETRY $err2\n";
            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_cb}->($self->{host}, $self->{port},
               sprintf (
                  "Error while writing from server '$self->{host}:$self->{port}': (%d|%s|%s)",
               $err2, (Net::SSLeay::ERR_error_string $err), "$!")
            );
            $self->end_sockets;
            return;
         }
      }
   } else {
      $self->debug_wrote_data (substr $self->{write_buffer}, 0, $l);
      $self->{write_buffer} = substr $self->{write_buffer}, $l;
      warn "WROTE[$l][$self->{write_buffer}]\n";
      if (length ($self->{write_buffer}) <= 0) {
         warn "DONE WRITING\n";
         delete $self->{w};
      }
   }
}

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

   if (defined $r) {
      $self->{read_buffer} .= decode_utf8 ($r);
      $self->handle_data (\$self->{read_buffer});
   } else {
      my $err2 = Net::SSLeay::get_error $self->{ssl}, $l;
      if ($err2 == 2 || $err2 == 3) {
         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_cb}->($self->{host}, $self->{port},
            sprintf (
               "Error while reading from server '$self->{host}:$self->{port}':"
               ."(%d|%s|%s)",
               $err2, (Net::SSLeay::ERR_error_string $err), "$!")
         );
         $self->end_sockets;
         return;
      }
   }
}

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

   my $cl = $self->{socket};
   $self->{write_buffer} .= $self->{ssl_enabled} ? encode_utf8 ($data) : $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;

   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;
}

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