1# -*-Perl-*-
2################################################################
3###
4###			  TcpTransaction.pm
5###
6### Author:  Internet Message Group <img@mew.org>
7### Created: Apr 23, 1997
8### Revised: Apr 23, 2007
9###
10
11my $PM_VERSION = "IM::TcpTransaction.pm version 20161010(IM153)";
12
13package IM::TcpTransaction;
14require 5.003;
15require Exporter;
16use IM::Config qw(dns_timeout connect_timeout command_timeout rcv_buf_siz);
17use Socket;
18BEGIN {
19    eval 'use Socket6' unless (eval '&AF_INET6');       # IPv6 patched Perl
20}
21use IM::Util;
22use IM::Ssh;
23use integer;
24use strict;
25use vars qw(@ISA @EXPORT);
26
27@ISA = qw(Exporter);
28@EXPORT = qw(log_transaction
29	connect_server tcp_command send_command next_response send_data
30	command_response set_command_response tcp_logging
31	get_session_log set_cur_server get_cur_server get_cur_server_original_form
32	pool_priv_sock);
33
34use vars qw($Cur_server $Cur_server_original_form $Session_log $TcpSockName
35	    $SOCK @Response $Logging @SockPool @Sock6Pool);
36BEGIN {
37    $Cur_server = '';
38    $Session_log = '';
39    $TcpSockName = 'tcp00';
40}
41
42sub log_transaction() {
43    use IM::Log;
44}
45
46##### MAKE TCP CONNECTION TO SPECIFIED SERVER #####
47#
48# connect_server(server_list, protocol, root)
49#	server_list: comma separated server list
50#	protocol: protocol name to be used with the servers
51#	root: privilidge port required
52#	return value: handle if success
53#
54sub connect_server($$$) {
55    my($servers, $serv, $root) = @_;
56
57    if ($#$servers < 0) {
58	im_err("no server specified for $serv\n");
59	return '';
60    }
61
62    $SIG{'ALRM'} = \&alarm_func;
63
64    no strict 'refs'; # XXX
65    local(*SOCK) = \*{$TcpSockName};
66    $SOCK = $serv;
67    @Response = ();
68    my(@he_infos);
69    my($s, $localport, $remoteport);
70    foreach $s (@$servers) {
71	$Cur_server_original_form = $s;
72	my($r) = ($#$servers >= 0) ? 'skipped' : 'failed';
73	# manage server[/remoteport]%localport
74	if ($s =~ s/\%(\d+)$//) {
75	    $localport = $1;
76	    $Cur_server = $s;
77	    if ($s =~ s/\/(\d+)$//) {
78		$remoteport = $1;
79	    } else {
80		next unless ($remoteport = getserv($serv, 'tcp'));
81	    }
82	    if ($main::SSH_server eq 'localhost') {
83		im_warn("Don't use port-forwarding to `localhost'.\n");
84		$Cur_server = "$s/$remoteport";
85	    } else {
86		if ($remoteport = &ssh_proxy($s,$remoteport,$localport,$main::SSH_server)) {
87		    $s = 'localhost';
88		    $Cur_server = "$Cur_server%$remoteport";
89		} else { # Connection failed.
90		    im_warn("Can't login to $main::SSH_server\n");
91		    if ($serv eq 'smtp') {
92			&log_action($serv, $Cur_server,
93				    join(',', @main::Recipients), $r, @Response);
94		    } else { # NNTP
95			&log_action($serv, $Cur_server,
96				    $main::Newsgroups, $r, @Response);
97		    }
98		    next;
99		}
100	    }
101	}
102	# manage server[/remoteport] notation
103	elsif ($s =~ /([^\/]*)\/(\d+)$/) {
104	    $remoteport = $2;
105	    $s = $1;
106	    $Cur_server = "$s/$remoteport";
107	} else {
108	    $remoteport = $serv;
109	    $Cur_server = $s;
110	}
111	$0 = progname() . ": im_getaddrinfo($s)";
112	@he_infos = im_getaddrinfo($s, $remoteport, AF_UNSPEC, SOCK_STREAM);
113	if ($#he_infos < 1) {
114	    im_warn("address unknown for $s\n");
115	    @Response = ("address unknown for $s");
116	    if ($serv eq 'smtp') {
117		&log_action($serv, $Cur_server,
118			    join(',', @main::Recipients), $r, @Response);
119	    } else { # NNTP
120		&log_action($serv, $Cur_server,
121			    $main::Newsgroups, $r, @Response);
122	    }
123	    next;
124	}
125	while ($#he_infos >= 0) {
126	    my($family, $socktype, $proto, $sin, $canonname)
127		= splice(@he_infos, 0, 5);
128	    if ($root && unixp()) {
129		my $name = priv_sock($family);
130		my $port;
131		if ($name eq '') {
132		    im_err("privilege port pool is empty.\n");
133		    return '';
134		}
135		if ($family == AF_INET) {
136		    $port = (unpack_sockaddr_in($sin))[0];
137		} else {
138		    $port = (unpack_sockaddr_in6($sin))[0];
139		}
140		*SOCK = \*{$name};
141		$SOCK = $port;
142	    } else {
143		unless (socket(SOCK, $family, $socktype, $proto)) {
144		    im_err("socket creation failed: $!.\n");
145		    return '';
146		}
147		if (defined(rcv_buf_siz())) {
148                    unless (setsockopt(SOCK, SOL_SOCKET, SO_RCVBUF, int(rcv_buf_siz()))) {
149                        im_err("setsockopt failed: $!.\n");
150                        return '';
151		    }
152                }
153	    }
154
155	    im_notice("opening $serv session to $s($remoteport).\n");
156	    alarm(connect_timeout()) unless win95p();
157	    $0 = progname() . ": connecting to $s with $serv";
158	    if (connect (SOCK, $sin)) {
159		alarm(0) unless win95p();
160		select (SOCK); $| = 1; select (STDOUT);
161		$Session_log .=
162		    "Transcription of $serv session follows:\n" if ($Logging);
163		im_debug("handle $TcpSockName allocated.\n")
164		    if (&debug('tcp'));
165		$TcpSockName++;
166		return *SOCK;
167	    }
168	    @Response = ($!);
169	    alarm(0) unless win95p();
170	    close(SOCK);
171	}
172	im_notice("$serv server $s($remoteport) did not respond.\n");
173	if ($serv eq 'smtp') {
174	    &log_action($serv, $Cur_server,
175			join(',', @main::Recipients), $r, @Response);
176	} else { # NNTP
177	    &log_action($serv, $Cur_server,
178			$main::Newsgroups, $r, @Response);
179	}
180    }
181    im_warn("WARNING: $serv connection was not established.\n");
182    return '';
183}
184
185##### CLIENT-SERVER HANDSHAKE #####
186#
187# tcp_command(channel, command, fake_message)
188#	channel: socket descriptor to send the command
189#	command: command string to be sent
190#	return value:
191#		 0: success
192#		 1: recoverable error (should be retried)
193#		-1: unrecoverable error
194#
195sub tcp_command($$$) {
196    my($CHAN, $command, $fake) = @_;
197    my($resp, $stat, $rcode, $logcmd);
198
199    @Response = ();
200    $stat = '';
201    if ($fake) {
202	$logcmd = $fake;
203    } else {
204	$logcmd = $command;
205    }
206    if ($command) {
207	im_notice("<<< $logcmd\n");
208	$Session_log .= "<<< $logcmd\n" if ($Logging);
209	unless (print $CHAN "$command\r\n") {
210	    # may be channel trouble
211	    @Response = ($!);
212	    return 1;
213	}
214	$0 = progname() . ": $logcmd ($Cur_server)";
215    } else {
216## if you have mysterious TCP/IP bug on IRIX/SGI
217#	print $CHAN ' ';
218## endif
219	$0 = progname() . ": greeting ($Cur_server)";
220    }
221    do {
222	alarm(command_timeout()) unless win95p();
223	$resp = <$CHAN>;
224	if (!defined($resp)) {
225	    # may be channel trouble
226	    @Response = ("$!");
227	}
228	alarm(0) unless win95p();
229	if (!defined($resp)) {
230	    # may be channel trouble
231	    return 1;
232	}
233	$resp =~ s/[\r\n]+$//;
234	if ($resp =~ /^([0-9][0-9][0-9])/) {
235	    $rcode = $1;
236	    if ($stat eq '' && $rcode !~ /^0/) {
237		$stat = $rcode;
238	    }
239	    push(@Response, $resp) if ($rcode !~ /^0/);	# XXX
240	}
241	im_notice(">>> $resp\n");
242	$Session_log .= ">>> $resp\n" if ($Logging);
243	last if ($resp =~ /^\.$/);
244    } while ($resp =~ /^...-/ || $resp =~ /^[^1-9]/);
245    return 0 if ($stat =~ /^[23]../);
246    return 1 if ($stat =~ /^4../);
247    return -1;
248}
249
250##### CLIENT-SERVER HANDSHAKE #####
251#
252# send_command(channel, command, fake_message)
253#	return value: the first line of responses
254#
255sub send_command($$$) {
256    my($CHAN, $command, $fake) = @_;
257    my($resp, $logcmd);
258    if ($command) {
259	print $CHAN "$command\r\n";
260	if ($fake) {
261	    $logcmd = $fake;
262	} else {
263	    $logcmd = $command;
264	}
265	im_notice("<<< $logcmd\n");
266	$Session_log .= "<<< $logcmd\n" if ($Logging);
267	$0 = progname() . ": $logcmd ($Cur_server)";
268    } else {
269	$0 = progname() . ": greeting ($Cur_server)";
270    }
271    alarm(command_timeout()) unless win95p();
272    $resp = <$CHAN>;
273    if (!defined($resp)) {
274	# may be channel trouble
275	im_notice("$!\n");
276    }
277    alarm(0) unless win95p();
278    if (!defined($resp)) {
279	# may be channel trouble
280	return '';
281    }
282    $resp =~ s/[\r\n]+/\n/;
283    im_notice(">>> $resp");
284    $Session_log .= ">>> $resp" if ($Logging);
285    chomp $resp;
286    return $resp;
287}
288
289sub send_data($$$) {
290    my($CHAN, $data, $fake) = @_;
291    my($logdata);
292    $data =~ s/\r?\n?$//;
293    print $CHAN "$data\r\n";
294    if ($fake) {
295	$logdata = $fake;
296    } else {
297	$logdata = $data;
298    }
299    im_notice("<<< $logdata\n");
300    $Session_log .= "<<< $logdata\n" if ($Logging);
301}
302
303sub next_response($) {
304    my $CHAN = shift;
305    my $resp;
306
307    alarm(command_timeout()) unless win95p();
308    $resp = <$CHAN>;
309    if (!defined($resp)) {
310	# may be channel trouble
311	im_notice("$!\n");
312    }
313    alarm(0) unless win95p();
314    if (!defined($resp)) {
315	# may be channel trouble
316	return '';
317    }
318    $resp =~ s/[\r\n]+/\n/;
319    im_notice(">>> $resp");
320    $Session_log .= ">>> $resp" if ($Logging);
321    chomp $resp;
322    return $resp;
323}
324
325sub command_response() {
326    return @Response;
327}
328
329sub set_command_response(@) {
330    @Response = @_;
331}
332
333sub tcp_logging($) {
334#   conversations are saved in $Session_log if true
335    $Logging = shift;
336}
337
338sub get_session_log() {
339    return $Session_log;
340}
341
342sub set_cur_server($) {
343    $Cur_server = shift;
344}
345
346sub get_cur_server() {
347    return $Cur_server;
348}
349
350sub get_cur_server_original_form() {
351    return $Cur_server_original_form;
352}
353
354sub pool_priv_sock($) {
355    my $count = shift;
356
357    pool_priv_sock_af($count, AF_INET);
358    if (eval 'pack_sockaddr_in6(110, pack("N4", 0, 0, 0, 0))') {
359	no strict 'subs'; # XXX for AF_INET6
360	pool_priv_sock_af($count, AF_INET6);
361    }
362}
363
364sub pool_priv_sock_af($$) {
365    my($count, $family) = @_;
366    my $privport = 1023;
367
368    no strict 'refs'; # XXX
369    my($pe_name, $pe_aliases, $pe_proto);
370    ($pe_name, $pe_aliases, $pe_proto) = getprotobyname ('tcp');
371    unless ($pe_name) {
372	$pe_proto = 6;
373    }
374    while ($count--) {
375	unless (socket(*{$TcpSockName}, $family, SOCK_STREAM, $pe_proto)) {
376	    im_err("socket creation failed: $!.\n");
377	    return -1;
378	}
379	while ($privport > 0) {
380	    my($ANYADDR, $psin);
381
382	    im_debug("binding port $privport.\n") if (&debug('tcp'));
383	    if ($family == AF_INET) {
384		$ANYADDR = pack('C4', 0, 0, 0, 0);
385		$psin = pack_sockaddr_in($privport, $ANYADDR);
386	    } else {
387		$ANYADDR = pack('N4', 0, 0, 0, 0);
388		$psin = pack_sockaddr_in6($privport, $ANYADDR);
389	    }
390	    last if (bind (*{$TcpSockName}, $psin));
391	    im_warn("privileged socket binding failed: $!.\n")
392		if (&debug('tcp'));
393	    $privport--;
394	}
395	if ($privport == 0) {
396	    im_err("binding to privileged port failed: $!.\n");
397	    return -1;
398	}
399	im_notice("pool_priv_sock: $TcpSockName got\n");
400	if ($family == AF_INET) {
401	    push(@SockPool, $TcpSockName);
402	} else {
403	    push(@Sock6Pool, $TcpSockName);
404	}
405	$TcpSockName++;
406    }
407    return 0;
408}
409
410sub priv_sock($) {
411    my($family) = shift;
412    my($sock_name);
413
414    if ($family == AF_INET) {
415	return '' if ($#SockPool < 0);
416	$sock_name = shift(@SockPool);
417    } else {
418	return '' if ($#Sock6Pool < 0);
419	$sock_name = shift(@Sock6Pool);
420    }
421    im_notice("priv_sock: $sock_name\n");
422    return $sock_name;
423}
424
425sub alarm_func {
426    im_die("connection error\n");
427}
428
429sub im_getaddrinfo($$;$$$$) {
430    return getaddrinfo(@_) if (defined &getaddrinfo);
431
432    my($node, $serv, $family, $socktype, $proto, $flags) = @_;
433
434    my($pe_name, $pe_aliases, $pe_proto, $se_port);
435    if (unixp()) {
436	$proto = 'tcp' unless ($proto);
437	($pe_name, $pe_aliases, $pe_proto) = getprotobyname($proto);
438    }
439    $pe_proto = 6 unless ($pe_name);
440    return unless ($se_port = getserv($serv, $proto));
441
442    my($he_name, $he_alias, $he_type, $he_len, @he_addrs);
443    if ($node =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
444	@he_addrs = (pack('C4', $1, $2, $3, $4));
445    } else {
446	alarm(dns_timeout()) unless win95p();
447	($he_name, $he_alias, $he_type, $he_len, @he_addrs)
448	  = gethostbyname($node);
449	alarm(0) unless win95p();
450	return unless ($he_name);
451    }
452
453    my($he_addr, @infos);
454    foreach $he_addr (@he_addrs) {
455	push(@infos, AF_INET, $socktype, $pe_proto,
456	     pack_sockaddr_in($se_port, $he_addr), $he_name);
457    }
458    @infos;
459}
460
461sub getserv($$) {
462    my($serv, $proto) = @_;
463
464    my($se_port);
465    if ($serv =~ /^\d+$/o) {
466	$se_port = $serv;
467    } else {
468	my($se_name, $se_aliases);
469	($se_name, $se_aliases, $se_port) = getservbyname($serv, $proto)
470	    if (unixp());
471	unless ($se_name) {
472	    if ($serv eq 'smtp') {
473		$se_port = 25;
474	    } elsif ($serv eq 'http') {
475		$se_port = 80;
476	    } elsif ($serv eq 'nntp') {
477		$se_port = 119;
478	    } elsif ($serv eq 'pop3') {
479		$se_port = 110;
480	    } elsif ($serv eq 'imap') {
481		$se_port = 143;
482	    } else {
483		im_err("unknown service: $serv\n");
484		return undef;
485	    }
486	}
487    }
488    $se_port;
489}
490
4911;
492
493__END__
494
495=head1 NAME
496
497IM::TcpTransaction - TCP transaction processing interface for SMTP and NNTP
498
499=head1 SYNOPSIS
500
501 use IM::TcpTransaction;
502
503 $socket = &connect_server(server_list, protocol, log_flag);
504 $return_code = &tcp_command(socket, command_string, log_flag);
505 @response = &command_response;
506 &set_command_response(response_string_list);
507
508=head1 DESCRIPTION
509
510The I<IM::TcpTransaction> module handles TCP transaction for SMTP and NNTP.
511
512This modules is provided by IM (Internet Message).
513
514=head1 COPYRIGHT
515
516IM (Internet Message) is copyrighted by IM developing team.
517You can redistribute it and/or modify it under the modified BSD
518license.  See the copyright file for more details.
519
520=cut
521
522### Copyright (C) 1997, 1998, 1999 IM developing team
523### All rights reserved.
524###
525### Redistribution and use in source and binary forms, with or without
526### modification, are permitted provided that the following conditions
527### are met:
528###
529### 1. Redistributions of source code must retain the above copyright
530###    notice, this list of conditions and the following disclaimer.
531### 2. Redistributions in binary form must reproduce the above copyright
532###    notice, this list of conditions and the following disclaimer in the
533###    documentation and/or other materials provided with the distribution.
534### 3. Neither the name of the team nor the names of its contributors
535###    may be used to endorse or promote products derived from this software
536###    without specific prior written permission.
537###
538### THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
539### ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
540### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
541### PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
542### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
543### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
544### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
545### BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
546### WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
547### OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
548### IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
549