Cutthrough: fix operation under -bhc to not actually deliver. Bug 1800
[exim.git] / src / util / proxy_protocol_client.pl
1 #!/usr/bin/perl
2 #
3 # Copyright (C) 2014 Todd Lyons
4 # License GPLv2: GNU GPL version 2
5 # <http://www.gnu.org/licenses/old-licenses/gpl-2.0.html>
6 #
7 # This script emulates a proxy which uses Proxy Protocol to communicate
8 # to a backend server.  It should be run from an IP which is configured
9 # to be a Proxy Protocol connection (or not, if you are testing error
10 # scenarios) because Proxy Protocol specs require not to fall back to a
11 # non-proxied mode.
12 #
13 # The script is interactive, so when you run it, you are expected to
14 # perform whatever conversation is required for the protocol being
15 # tested.  It uses STDIN/STDOUT, so you can also pipe output to/from the
16 # script.  It was originally written to test Exim's Proxy Protocol
17 # code, and it could be tested like this:
18 #
19 # swaks --pipe 'perl proxy_protocol_client.pl --server-ip
20 #   host.internal.lan' --from user@example.com --to user@example.net
21 #
22 use strict;
23 use warnings;
24 use IO::Select;
25 use IO::Socket;
26 use Getopt::Long;
27 use Data::Dumper;
28
29 my %opts;
30 GetOptions( \%opts,
31   'help',
32   '6|ipv6',
33   'dest-ip:s',
34   'dest-port:i',
35   'source-ip:s',
36   'source-port:i',
37   'server-ip:s',
38   'server-port:i',
39   'version:i'
40 );
41 &usage() if ($opts{help} || !$opts{'server-ip'});
42
43 my ($dest_ip,$source_ip,$dest_port,$source_port);
44 my %socket_map;
45 my $status_line = "Testing Proxy Protocol Version " .
46                   ($opts{version} ? $opts{version} : '2') .
47                   ":\n";
48
49 # All ip's and ports are in network byte order in version 2 mode, but are
50 # simple strings when in version 1 mode.  The binary_pack_*() functions
51 # return the required data for the Proxy Protocol version being used.
52
53 # Use provided source or fall back to www.mrball.net
54 $source_ip   = $opts{'source-ip'} ?  binary_pack_ip($opts{'source-ip'}) :
55                  $opts{6} ?
56                  binary_pack_ip("2001:470:d:367::50") :
57                  binary_pack_ip("208.89.139.252");
58 $source_port = $opts{'source-port'} ?
59                  binary_pack_port($opts{'source-port'}) :
60                  binary_pack_port(43118);
61
62 $status_line .= "-> " if (!$opts{version} || $opts{version} == 2);
63
64 # Use provided dest or fall back to mail.exim.org
65 $dest_ip   = $opts{'dest-ip'} ?  binary_pack_ip($opts{'dest-ip'}) :
66                $opts{6} ?
67                binary_pack_ip("2001:630:212:8:204:23ff:fed6:b664") :
68                binary_pack_ip("131.111.8.192");
69 $dest_port = $opts{'dest-port'} ?
70                binary_pack_port($opts{'dest-port'}) :
71                binary_pack_port(25);
72
73 # The IP and port of the Proxy Protocol backend real server being tested,
74 # don't binary pack it.
75 my $server_ip   = $opts{'server-ip'};
76 my $server_port = $opts{'server-port'} ? $opts{'server-port'} : 25;
77
78 my $s = IO::Select->new(); # for socket polling
79
80 sub generate_preamble {
81   my @preamble;
82   if (!$opts{version} || $opts{version} == 2) {
83     @preamble = (
84       "\x0D\x0A\x0D\x0A\x00\x0D\x0A\x51\x55\x49\x54\x0A", # 12 byte v2 header
85       "\x21",                                             # top 4 bits declares v2
86                                                           # bottom 4 bits is command
87       $opts{6} ? "\x21" : "\x11",                         # inet6/4 and TCP (stream)
88       $opts{6} ? "\x00\x24" : "\x00\x0b",                 # 36 bytes / 12 bytes
89       $source_ip,
90       $dest_ip,
91       $source_port,
92       $dest_port
93     );
94   }
95   else {
96     @preamble = (
97       "PROXY", " ",                                       # Request proxy mode
98       $opts{6} ? "TCP6" : "TCP4", " ",                    # inet6/4 and TCP (stream)
99       $source_ip, " ",                                    
100       $dest_ip, " ",
101       $source_port, " ",
102       $dest_port,
103       "\x0d\x0a"
104     );
105     $status_line .= join "", @preamble;
106   }
107   print "\n", $status_line, "\n";
108   print "\n" if (!$opts{version} || $opts{version} == 2);
109   return @preamble;
110 }
111
112 sub binary_pack_port {
113   my $port = shift();
114   if ($opts{version} && $opts{version} == 1) {
115     return $port
116       if ($port && $port =~ /^\d+$/ && $port > 0 && $port < 65536);
117     die "Not a valid port: $port";
118   }
119   $status_line .= $port." ";
120   $port = pack "S", $port;
121   return $port;
122 }
123
124 sub binary_pack_ip {
125   my $ip = shift();
126   if ( $ip =~ m/\./ && !$opts{6}) {
127     if (IP4_valid($ip)) {
128       return $ip if ($opts{version} && $opts{version} == 1);
129       $status_line .= $ip.":";
130       $ip = pack "C*", split /\./, $ip;
131     }
132     else { die "Invalid IPv4: $ip"; }
133   }
134   elsif ($ip =~ m/:/ && $opts{6}) {
135     $ip = pad_ipv6($ip);
136     if (IP6_valid($ip)) {
137       return $ip if ($opts{version} && $opts{version} == 1);
138       $status_line .= $ip.":";
139       $ip = pack "S>*", map hex, split /:/, $ip;
140     }
141     else { die "Invalid IPv6: $ip"; }
142   }
143   else { die "Mismatching IP families passed: $ip"; }
144   return $ip;
145 }
146
147 sub pad_ipv6 {
148   my $ip = shift();
149   my @ip = split /:/, $ip;
150   my $segments = scalar @ip;
151   return $ip if ($segments == 8);
152   $ip = "";
153   for (my $count=1; $count <= $segments; $count++) {
154     my $block = $ip[$count-1];
155     if ($block) {
156       $ip .= $block;
157       $ip .= ":" unless $count == $segments;
158     }
159     elsif ($count == 1) {
160       # Somebody passed us ::1, fix it, but it's not really valid
161       $ip = "0:";
162     }
163     else {
164       $ip .= join ":", map "0", 0..(8-$segments);
165       $ip .= ":";
166     }
167   }
168   return $ip;
169 }
170
171 sub IP6_valid {
172   my $ip = shift;
173   $ip = lc($ip);
174   return 0 unless ($ip =~ /^[0-9a-f:]+$/);
175   my @ip = split /:/, $ip;
176   return 0 if (scalar @ip != 8);
177   return 1;
178 }
179
180 sub IP4_valid {
181   my $ip = shift;
182   $ip =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/;
183   foreach ($1,$2,$3,$4){
184     if ($_  <256 && $_ >0) {next;}
185     return 0;
186   }
187   return 1;
188 }
189
190 sub go_interactive {
191   my $continue = 1;
192   while($continue) {
193     # Check for input on both ends, recheck every 5 sec
194     for my $socket ($s->can_read(5)) {
195       my $remote = $socket_map{$socket};
196       my $buffer;
197       my $read = $socket->sysread($buffer, 4096);
198       if ($read) {
199         $remote->syswrite($buffer);
200       }
201       else {
202         $continue = 0;
203       }
204     }
205   }
206 }
207
208 sub connect_stdin_to_proxy {
209   my $sock = new IO::Socket::INET(
210                PeerAddr => $server_ip,
211                PeerPort => $server_port,
212                Proto    => 'tcp'
213              );
214
215   die "Could not create socket: $!\n" unless $sock;
216   # Add sockets to the Select group
217   $s->add(\*STDIN);
218   $s->add($sock);
219   # Tie the sockets together using this hash
220   $socket_map{\*STDIN} = $sock;
221   $socket_map{$sock} = \*STDOUT;
222   return $sock;
223 }
224
225 sub usage {
226   chomp(my $prog = `basename $0`);
227   print <<EOF;
228 Usage: $prog [required] [optional]
229   Required:
230     --server-ip   IP of server to test proxy configuration,
231                   a hostname is ok, but for only this setting
232   Optional:
233     --server-port Port server is listening on (default 25)
234     --6           IPv6 source/dest (default IPv4), if none specified,
235                   some default, reverse resolvable IP's are used for
236                   the source and dest ip/port
237     --dest-ip     Public IP of the proxy server
238     --dest-port   Port of public IP of proxy server
239     --source-ip   IP connecting to the proxy server
240     --source-port Port of IP connecting to the proxy server
241     --help        This output
242 EOF
243   exit;
244 }
245
246
247 my $sock = connect_stdin_to_proxy();
248 my @preamble = generate_preamble();
249 print $sock @preamble;
250 go_interactive();