line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package NET::MitM; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
=head1 NAME |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
NET::MitM - Man in the Middle - connects a client and a server, giving visibility of and control over messages passed. |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
=head1 VERSION |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
Version 0.01_03 |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
=cut |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our $VERSION = '0.01_03'; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
=head1 SYNOPSIS |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
NET::MitM is designed to be inserted between a client and a server. It proxies all traffic through verbatum, and also copies that same data to a log file and/or a callback function, allowing a data session to be monitored, recorded, even altered on the fly. |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
MitM acts as a 'man in the middle', sitting between the client and server. To the client, MitM looks like the server. To the server, MitM looks like the client. |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
MitM cannot be used to covertly operate on unsuspecting client/server sessions - it requires that you control either the client or the server. If you control the client, you can tell it to connect via your MitM. If you control the server, you can move it to a different port, and put a MitM in its place. |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
When started, MitM opens a socket and listens for connections. When that socket is connected to, MitM opens another connection to the server. Messages from either client or server are passed to the other, and a copy of each message is, potentially, logged. Alternately, callback methods may be used to add business logic, including potentially altering the messages being passed. |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
MitM can also be used as a proxy to allow two processes on machines that cannot 'see' each other to communicate via an intermediary machine that is visible to both. |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
There is an (as yet unreleased) sister module L that allows a MitM session to be replayed. |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
=head3 For example |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
Assume the following script is running on the local machine: |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
use NET::MitM; |
34
|
|
|
|
|
|
|
my $MitM = NET::MitM->new("cpan.org", 80, 10080); |
35
|
|
|
|
|
|
|
$MitM->log_file("MitM.log"); |
36
|
|
|
|
|
|
|
$MitM->go(); |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
A browser connecting to L will now cause MitM to open a connection to cpan.org, and messages sent by either end will be passed to the other end, and logged to MitM.log. |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
For another example, see samples/mitm.pl in the MitM distribution. |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
=head2 Modifying messages on the fly. |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
However you deploy MitM, it will be virtually identical to having the client and server talk directly. The difference will be that either the client and/or server will be at an address other than the one its counterpart believes it to be at. Most programs ignore this, but sometimes it matters. |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
For example, HTTP browsers pass a number of parameters, one of which is "Host", the host to which the browser believes it is connecting. Often, this parameter is unused. But sometimes, a single HTTP server will be serving content for more than one website. Such a server generally relies on the Host parameter to know what it is to return. If the MitM is not on the same host as the HTTP server, the host parameter that the browser passes will cause the HTTP server to fail to serve the desired pages. |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
Further, HTTP servers typically return URLs containing the host address. If the browser navigates to a returned URL, it will from that point onwards connect directly to the server in the URL instead of communicating via MitM. |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
Both of these problems can be worked around by modifying the messages being passed. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
For example, assume the following script is running on the local machine: |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
use NET::MitM; |
55
|
|
|
|
|
|
|
sub send_($) {$_[0] =~ s/Host: .*:\d+/Host: cpan.org/;} |
56
|
|
|
|
|
|
|
sub receive($) {$_[0] =~ s/cpan.org:\d+/localhost:10080/g;} |
57
|
|
|
|
|
|
|
my $MitM = NET::MitM->new("cpan.org", 80, 10080); |
58
|
|
|
|
|
|
|
$MitM->client_to_server_callback(\&send); |
59
|
|
|
|
|
|
|
$MitM->server_to_client_callback(\&receive); |
60
|
|
|
|
|
|
|
$MitM->log_file("http_MitM.log"); |
61
|
|
|
|
|
|
|
$MitM->go(); |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
The send callback tells the server that it is to serve cpan.org pages, instead of some other set of pages, while the receive callback tells the browser to access cpan.org URLs via the MitM process, not directly. The HTTP server will now respond properly, even though the browser sent the wrong hostname, and the browser will now behave as desired and direct future requests via the MitM. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
For another example, see samples/http_mitm.pl in the MitM distribution. |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
A more difficult problem is security aware processes, such as those that use HTTPS based protocols. They are actively hostname aware. Precisely to defend against a man-in-the-middle attack, they check their counterpart's reported hostname (but not normally the port) against the actual hostname. Unless client, server and MitM are all on the same host, either the client or the server will notice that the remote hostname is not what it should be, and will abort the connection. |
68
|
|
|
|
|
|
|
There is no good workaround for this, unless you can run an instance of MitM on the server, and another on the client - but even if you do, you still have to deal with the communication being encrypted. |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
=head1 SUBROUTINES/METHODS |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
=cut |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# ####### |
75
|
|
|
|
|
|
|
# Globals |
76
|
|
|
|
|
|
|
# ####### |
77
|
|
|
|
|
|
|
|
78
|
2
|
|
|
2
|
|
30424
|
use 5.002; |
|
2
|
|
|
|
|
8
|
|
79
|
2
|
|
|
2
|
|
10
|
use warnings FATAL => 'all'; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
92
|
|
80
|
2
|
|
|
2
|
|
1193
|
use Socket; |
|
2
|
|
|
|
|
7817
|
|
|
2
|
|
|
|
|
909
|
|
81
|
2
|
|
|
2
|
|
970
|
use FileHandle; |
|
2
|
|
|
|
|
19070
|
|
|
2
|
|
|
|
|
12
|
|
82
|
2
|
|
|
2
|
|
621
|
use IO::Handle; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
66
|
|
83
|
2
|
|
|
2
|
|
8
|
use Carp; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
102
|
|
84
|
2
|
|
|
2
|
|
8
|
use strict; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
6988
|
|
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
my $protocol = getprotobyname('tcp'); # TODO: make dynamic? |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
=head2 new( remote_ip_address, local_port_num, remote_port_num ) |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
Creates a new MitM |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
=head3 Parameters |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=over |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
=item * remote_ip_address - the remote hostname/IP address of the server |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
=item * remote_port_num - the remote port number of the server |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=item * local_port_num - the port number to listen on |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=back |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
=head3 Usage |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
To keep a record of all messages sent: |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
use NET::MitM; |
109
|
|
|
|
|
|
|
my $MitM = NET::MitM->new("www.cpan.org", 80, 10080); |
110
|
|
|
|
|
|
|
$MitM->log_file("MitM.log"); |
111
|
|
|
|
|
|
|
$MitM->go(); |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=cut |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub hhmmss(); |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
my $mitm_count=0; |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
sub _new(){ |
120
|
0
|
|
|
0
|
|
|
my %this; |
121
|
0
|
|
|
|
|
|
$this{verbose} = 1; |
122
|
0
|
|
|
|
|
|
$this{parallel} = 0; |
123
|
0
|
|
|
|
|
|
$this{mydate} = \&hhmmss; |
124
|
0
|
|
|
|
|
|
$this{name} = "MitM".++$mitm_count; |
125
|
0
|
|
|
|
|
|
return \%this; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
sub new($$;$$$) { |
129
|
0
|
|
|
0
|
1
|
|
my $class=shift; |
130
|
0
|
|
|
|
|
|
my $this=_new(); |
131
|
0
|
0
|
|
|
|
|
$this->{remote_ip_address} = shift or croak "remote hostname/ip address missing"; |
132
|
0
|
0
|
|
|
|
|
$this->{remote_port_num} = shift or croak "remote port number missing"; |
133
|
0
|
|
0
|
|
|
|
$this->{local_port_num} = shift || $this->{remote_port_num}; |
134
|
0
|
|
|
|
|
|
return bless($this, $class); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=head2 go( ) |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
Listen on local_port, accept incoming connections, and forwards messages back and forth. |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
=head3 Parameters |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=over |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=item * --none-- |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
=back |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
=head3 Usage |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
When a connection on local_port is received a connect to remote_ip_address:remote_port is created and messages from the client are passed to the server and vice-versa. |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
If parallel() was set, which is not the default, there will be a new process created for each such session. |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
If any callback functions have been set, they will be called before each message is passed. |
156
|
|
|
|
|
|
|
If logging is on, messages will be logged. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
go() does not return. You may want to L before calling it. There is no way to stop it from outside except using a signal to interrupt it. This will probably change in a future release of MitM. |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
If new_server() was used instead of new(), messages from client are instead passed to the server callback function. |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
=cut |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
# Convenience function - intentionally not exposed. If you really want to call it, you can of course. But if you are going to violate encapsulation, why not go directly to the variables? |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub _set($;$) { |
167
|
0
|
|
|
0
|
|
|
my $this=shift; |
168
|
0
|
0
|
|
|
|
|
my $key=shift or confess "missing mandatory parameter"; |
169
|
0
|
|
|
|
|
|
my $value=shift; |
170
|
0
|
0
|
|
|
|
|
if(defined $value){ |
171
|
0
|
|
|
|
|
|
$this->{$key} = $value; |
172
|
|
|
|
|
|
|
} |
173
|
0
|
|
|
|
|
|
return $this->{$key}; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=head2 name( [name] ) |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
Names the object - will be reported back in logging/debug |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
=head3 Parameters |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
=over |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
=item * name - the new name (default is MitM1, MitM2, ...) |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=item * Returns - the current or new setting |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
=back |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
=head3 Usage |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
For a minimal MitM: |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
use NET::MitM; |
195
|
|
|
|
|
|
|
my $MitM = NET::MitM->new("www.cpan.org", 80, 10080); |
196
|
|
|
|
|
|
|
$MitM->go(); |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
=cut |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
sub name(;$) { |
201
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
202
|
0
|
|
|
|
|
|
my $value=shift; |
203
|
0
|
|
|
|
|
|
return $this->_set("name", $value); |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
=head2 verbose( [level] ) |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
Turns on/off reporting to stdout. |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=head3 Parameters |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=over |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
=item * level - how verbose to be. 0=nothing, 1=normal, 2=debug. The default is 1. |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
=item * Returns - the current or new setting |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=back |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
=head3 Usage |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=cut |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub verbose(;$) { |
225
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
226
|
0
|
|
|
|
|
|
my $verbose=shift; |
227
|
|
|
|
|
|
|
#warn "verbose->(",$verbose||"--undef--",")\n"; |
228
|
0
|
|
|
|
|
|
return $this->_set("verbose", $verbose); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=head2 client_to_server_callback( callback ) |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
Set a callback function to monitor/modify each message sent to server |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
=head3 Parameters |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
=over |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
=item * callback - a reference to a function to be called for each message sent to server |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
=item * Returns - the current or new setting |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
=back |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=head3 Usage |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
If client_to_server_callback is set, it will be called with a copy of each message to the server before it is sent. Whatever the callback returns will be sent. |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
For example, to modify messages: |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
use NET::MitM; |
252
|
|
|
|
|
|
|
sub send_($) {$_[0] =~ s/Host: .*:\d+/Host: cpan.org/;} |
253
|
|
|
|
|
|
|
sub receive($) {$_[0] =~ s/www.cpan.org(:\d+)?/localhost:10080/g;} |
254
|
|
|
|
|
|
|
my $MitM = NET::MitM->new("www.cpan.org", 80, 10080); |
255
|
|
|
|
|
|
|
$MitM->client_to_server_callback(\&send); |
256
|
|
|
|
|
|
|
$MitM->server_to_client_callback(\&receive); |
257
|
|
|
|
|
|
|
$MitM->go(); |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
If the callback is readonly, it should either return a copy of the original message, or undef. Be careful not to accidentally return something else - remember that perl methods implicitly returns the value of the last command executed. |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
For example, to write messages to a log: |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
sub peek($) {my $msg = shift; print LOG; return $msg;} |
264
|
|
|
|
|
|
|
my $MitM = NET::MitM->new("www.cpan.org", 80, 10080); |
265
|
|
|
|
|
|
|
$MitM->client_to_server_callback(\&peek); |
266
|
|
|
|
|
|
|
$MitM->server_to_client_callback(\&peek); |
267
|
|
|
|
|
|
|
$MitM->go(); |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
This would also work: |
270
|
|
|
|
|
|
|
sub peek($) {my $msg = shift; print LOG; return undef;} |
271
|
|
|
|
|
|
|
... |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
Whereas this is unlikely to do what you would want: |
274
|
|
|
|
|
|
|
sub peek($) {my $msg = shift; print LOG} |
275
|
|
|
|
|
|
|
... |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
=cut |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
sub client_to_server_callback(;$) { |
280
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
281
|
0
|
|
|
|
|
|
my $callback=shift; |
282
|
0
|
|
|
|
|
|
return $this->_set("client_to_server_callback", $callback); |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=head2 server_to_client_callback( [callback] ) |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
Set a callback function to monitor/modify each message received from server |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=head3 Parameters |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=over |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
=item * callback - a reference to a function to be called for each inward message |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
=item * Returns - the current or new setting |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
=back |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
=head3 Usage |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
If server_to_client_callback is set, it will be called with a copy of each message received from the server before it is sent to the client. Whatever the callback returns will be sent. |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
If the callback is readonly, it should either return a copy of the original message, or undef. Be careful not to accidentally return something else - remember that perl methods implicitly returns the value of the last command executed. |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
=cut |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
sub server_to_client_callback(;$) { |
308
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
309
|
0
|
|
|
|
|
|
my $callback=shift; |
310
|
0
|
|
|
|
|
|
return $this->_set("server_to_client_callback", $callback); |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
=head2 timer_callback( [interval, callback] ) |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
Set a callback function to be called at regular intervals |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
=head3 Parameters |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
=over |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
=item * interval - how often the callback function is to be called - must be > 0 seconds, may be fractional |
322
|
|
|
|
|
|
|
=item * callback - a reference to a function to be called every interval seconds |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
=item * Returns - the current or new setting, as an array |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=back |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
=head3 Usage |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
If the callback is set, it will be called every interval seconds. Interval must be > 0 seconds. It may be a fraction of a second. If interval is passed as 0, or less, it will be reset to 1 second. This is to prevent accidental spin-wait. If you really want to spin-wait, pass an extremely small but non-zero interval. |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
If the callback returns false, mainloop will exit and return control to the caller. |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
The time spent in callbacks is not additional to the specified interval - the timer callback will be called every interval seconds, or as close as possible to every interval seconds. |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
Please remember that if you have called fork before calling go() that the timer_callback method will be executed in a different process to the parent - the two processes will need to use some form of L to communicate . |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
=cut |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
sub timer_callback(;$) { |
341
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
342
|
0
|
|
|
|
|
|
my $interval=shift; |
343
|
0
|
|
|
|
|
|
my $callback=shift; |
344
|
0
|
|
|
|
|
|
$interval=$this->_set("timer_interval", $interval); |
345
|
0
|
|
|
|
|
|
$callback=$this->_set("timer_callback", $callback); |
346
|
0
|
|
|
|
|
|
return ($interval, $callback); |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
=head2 parallel( [level] ) |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
Turns on/off running in parallel. |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
=head3 Parameters |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
=over |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
=item * level - 0=serial, 1=parallel. Default is 0 (run in serial). |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
=item * Returns - the current or new setting |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
=back |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
=head3 Usage |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
If running in parallel, MitM starts a new process for each new connection using L. |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
Running in serial still allows multiple clients to run concurrently, as so long as none of them have long-running callbacks. If they do, they will block other clients from sending/recieving. |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
=cut |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
sub parallel(;$) { |
372
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
373
|
0
|
|
|
|
|
|
my $parallel=shift; |
374
|
0
|
|
|
|
|
|
return $this->_set("parallel", $parallel); |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
=head2 serial( [level] ) |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
Turns on/off running in serial |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
=head3 Parameters |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
=over |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
=item * level - 0=parallel, 1=serial. Default is 1, i.e. run in serial. |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
=item * Returns - the current or new setting |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
=back |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
=head3 Usage |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
Calling this function with level=$l is exactly equivalent to calling parallel with level=!$l. |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
If running in parallel, MitM starts a new process for each new connection using L. |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
Running in serial, which is the default, still allows multiple clients to run concurrently, as so long as none of them have long-running callbacks. If they do, they will block other clients from sending/recieving. |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
=cut |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
sub serial(;$) { |
402
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
403
|
0
|
|
|
|
|
|
my $level=shift; |
404
|
0
|
0
|
|
|
|
|
my $parallel = $this->parallel(defined $level ? ! $level : undef); |
405
|
0
|
0
|
|
|
|
|
return $parallel ? 0 : 1; |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
=head2 log_file( [log_file_name] ] ) |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
log_file() sets, or clears, a log file. |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
=head3 Parameters |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
=over |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
=item * log_file_name - the name of the log file to be appended to. Passing "" disables logging. Passing nothing, or undef, returns the current log filename without change. |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=item * Returns: log file name |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
=back |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
=head3 Usage |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
The log file contains a record of connects and disconnects and messages as sent back and forwards. Log entries are timestamped. If the log file already exists, it is appended to. |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
The default timestamp is "hh:mm:ss", eg 19:49:43 - see mydate() and hhmmss(). |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
=cut |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
sub log_file(;$) { |
431
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
432
|
0
|
|
|
|
|
|
my $new_log_file=shift; |
433
|
0
|
0
|
|
|
|
|
if(defined $new_log_file){ |
434
|
0
|
0
|
|
|
|
|
if(!$new_log_file){ |
435
|
0
|
0
|
|
|
|
|
if($this->{LOGFILE}){ |
436
|
0
|
|
|
|
|
|
close($this->{LOGFILE}); |
437
|
0
|
|
|
|
|
|
$this->{log_file}=$this->{LOGFILE}=undef; |
438
|
0
|
0
|
|
|
|
|
print "Logging turned off\n" if $this->{verbose}; |
439
|
|
|
|
|
|
|
} |
440
|
|
|
|
|
|
|
}else{ |
441
|
0
|
|
|
|
|
|
my $LOGFILE; |
442
|
0
|
0
|
|
|
|
|
if( open($LOGFILE, ">>$new_log_file") ) { |
443
|
0
|
|
|
|
|
|
binmode($LOGFILE); |
444
|
0
|
|
|
|
|
|
$LOGFILE->autoflush(1); # TODO make this configurable? |
445
|
0
|
|
|
|
|
|
$this->{log_file}=$new_log_file; |
446
|
0
|
|
|
|
|
|
$this->{LOGFILE}=$LOGFILE; |
447
|
|
|
|
|
|
|
} |
448
|
|
|
|
|
|
|
else { |
449
|
0
|
0
|
|
|
|
|
print "Failed to open $new_log_file for logging: $!" if $this->{verbose}; |
450
|
|
|
|
|
|
|
} |
451
|
0
|
0
|
0
|
|
|
|
print "Logging to $this->{log_file}\n" if $this->{verbose} && $this->{log_file}; |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
} |
454
|
0
|
|
|
|
|
|
return $this->{log_file}; |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
=head2 defrag_delay( [delay] ) |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
Use a small delay to defragment messages |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
=head3 Parameters |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
=over |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
=item * Delay - seconds to wait - fractions of a second are OK |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
=item * Returns: the current setting. |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
=back |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
=head3 Usage |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
Under TCPIP, there is always a risk that large messages will be fragmented in transit, and that messages sent close together may be concatenated. |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
Client/Server programs have to know how to turn a stream of bytes into the messages they care about, either by repeatedly reading until they see an end-of-message (defragmenting), or by splitting the bytes read into multiple messages (deconcatenating). |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
For our purposes, fragmentation and concatenation can make our logs harder to read. |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
Without knowning the protocol, it's not possible to tell for sure if a message has been fragmented or concatenated. |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
A small delay can be used as a way of defragmenting messages, although it increases the risk that separate messages may be concatenated. |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
Eg: |
484
|
|
|
|
|
|
|
$MitM->defrag_delay( 0.1 ); |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
=cut |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
sub defrag_delay(;$) { |
489
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
490
|
0
|
|
|
|
|
|
my $defrag_delay=shift; |
491
|
0
|
|
|
|
|
|
return $this->_set("defrag_delays",$defrag_delay); |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
=head1 SUPPORTING SUBROUTINES/METHODS |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
The remaining functions are supplimentary. new_server() and new_client() provide a simple client and a simple server that may be useful in some circumstances. The other methods are only likely to be useful if you choose to bypass go() in order to, for example, have more control over messages being received and sent. |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
=head2 new_server( local_port_num, callback_function ) |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
Returns a very simple server, adequate for simple tasks. |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
=head3 Parameters |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
=over |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
=item * local_port_num - the Port number to listen on |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
=item * callback_function - a reference to a function to be called when a message arrives - must return a response which will be returned to the client |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
=item * Returns: a new server |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
=back |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
=head3 Usage |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
sub do_something($){ |
517
|
|
|
|
|
|
|
my $in = shift; |
518
|
|
|
|
|
|
|
my $out = ... |
519
|
|
|
|
|
|
|
return $out; |
520
|
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
my $server = NET::MitM::new_server(8080,\&do_something) || die; |
523
|
|
|
|
|
|
|
$server->go(); |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
The server returned by new_server has a method, go(), which tells it to start receiving messages (arbitrary strings). Each string is passed to the callback_function, which is expected to return a single string, being the response to be returned to caller. If the callback returns undef, the original message will be echoed back to the client. |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
go() does not return. You may want to L before calling it. |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
See, for another example, samples/echo_server.pl in the MitM distribution. |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
=cut |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
sub new_server($%) { |
534
|
0
|
|
|
0
|
1
|
|
my $class=shift; |
535
|
0
|
|
|
|
|
|
my $this=_new(); |
536
|
0
|
0
|
|
|
|
|
$this->{local_port_num} = shift or croak "no port number passed"; |
537
|
0
|
0
|
|
|
|
|
$this->{server_callback} = shift or croak "no callback passed"; |
538
|
0
|
|
|
|
|
|
return bless $this; |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
=head2 new_client( remote_host, local_port_num ) |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
new client returns a very simple client, adequate for simple tasks |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
The server returned has a method, send_and_receive(), which sends a message and receives a response. |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
Alternately, send_to_server() may be used to send a message, and read_from_server() may be used to receive a message. |
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
Explicitly calling connect_to_server() is optional, but may be useful if you want to be sure the server is reachable. If you don't call it explicitly, it will be called the first time a message is sent. |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
=head3 Parameters |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
=over |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
=item * remote_ip_address - the hostname/IP address of the server |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
=item * remote_port_num - the Port number of the server |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
=back |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
=head3 Usage |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
my $client = NET::MitM::new_client("localhost", 8080) || die("failed to start test client: $!"); |
564
|
|
|
|
|
|
|
$client->connect_to_server(); |
565
|
|
|
|
|
|
|
my $resp = $client->send_and_receive("hello"); |
566
|
|
|
|
|
|
|
... |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
See, for example, samples/client.pl or samples/clients.pl in the MitM distribution. |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
=cut |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
sub new_client($%) { |
573
|
0
|
|
|
0
|
1
|
|
my $class=shift; |
574
|
0
|
|
|
|
|
|
my $this=_new(); |
575
|
0
|
0
|
|
|
|
|
$this->{remote_ip_address} = shift or croak "remote hostname/ip address missing"; |
576
|
0
|
0
|
|
|
|
|
$this->{remote_port_num} = shift or croak "remote port number missing"; |
577
|
0
|
|
|
|
|
|
return bless $this; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
=head2 log( string ) |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
log is a convenience function that prefixes output with a timestamp and PID information then writes to log_file. |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
=head3 Parameters |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
=over |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
=item * string(s) - one or more strings to be logged |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
=back |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
=head3 Usage |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
log is a convenience function that prefixes output with a timestamp and PID information then writes to log_file. |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
log() does nothing unless log_file is set, which by default, it is not. |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
=cut |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
sub log($@) |
601
|
|
|
|
|
|
|
{ |
602
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
603
|
0
|
0
|
|
|
|
|
printf {$this->{LOGFILE}} "%u/%s %s\n", $$, $this->{mydate}(), "@_" if $this->{LOGFILE}; |
|
0
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
=head2 echo( string(s) ) |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
Prints to stdout and/or the logfile |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
=head3 Parameters |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
=over |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
=item * string(s) - one or more strings to be echoed (printed) |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
=back |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
=head3 Usage |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
echo() is a convenience function that prefixes output with a timestamp and PID information and prints it to standard out if verbose is set and, if log_file() has been set, logs it to the log file. |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
=cut |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
sub echo($@) |
625
|
|
|
|
|
|
|
{ |
626
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
627
|
0
|
|
|
|
|
|
$this->log("@_"); |
628
|
0
|
0
|
|
|
|
|
return if !$this->{verbose}; |
629
|
0
|
0
|
|
|
|
|
confess "Did not expect not to have a name" if !$this->{name}; |
630
|
0
|
0
|
|
|
|
|
if($_[0] =~ m/^[<>]{3}$/){ |
631
|
0
|
|
|
|
|
|
my $prefix=shift; |
632
|
0
|
|
|
|
|
|
my $msg=join "", @_; |
633
|
0
|
|
|
|
|
|
printf("%s: %u/%s %s %d bytes\n", $this->{name}, $$, $this->{mydate}(), $prefix, length($msg)); |
634
|
|
|
|
|
|
|
}else{ |
635
|
0
|
|
|
|
|
|
printf("%s: %u/%s\n", $this->{name}, $$, join(" ", $this->{mydate}(), @_)); |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
=head2 send_to_server( string(s) ) |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
send_to_server() sends a message to the server |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
=head3 Parameters |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
=over |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
=item * string(s) - one or more strings to be sent |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
=back |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
=head3 Usage |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
If a callback is set, it will be called before the message is sent. |
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
=cut |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
sub _do_callback($$) |
658
|
|
|
|
|
|
|
{ |
659
|
0
|
|
|
0
|
|
|
my $callback = shift; |
660
|
0
|
|
|
|
|
|
my $msg = shift; |
661
|
0
|
0
|
|
|
|
|
if($callback){ |
662
|
0
|
|
|
|
|
|
my $new_msg = $callback->($msg); |
663
|
0
|
0
|
|
|
|
|
$msg = $new_msg unless !defined $new_msg; |
664
|
|
|
|
|
|
|
} |
665
|
0
|
|
|
|
|
|
return $msg; |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
sub _logmsg |
669
|
|
|
|
|
|
|
{ |
670
|
0
|
|
|
0
|
|
|
my $this = shift; |
671
|
0
|
|
|
|
|
|
my $direction = shift; |
672
|
0
|
|
|
|
|
|
my $msg = shift; |
673
|
0
|
0
|
|
|
|
|
if($this->{verbose}>1){ |
674
|
0
|
|
|
|
|
|
$this->echo($direction,"(".length($msg)." bytes) {$msg}\n"); |
675
|
|
|
|
|
|
|
}else{ |
676
|
|
|
|
|
|
|
# don't print the whole message by default, in case it is either binary &/or long |
677
|
0
|
|
|
|
|
|
$this->echo($direction,"(".length($msg)." bytes)\n"); |
678
|
0
|
|
|
|
|
|
$this->log($direction," {{{$msg}}}\n"); |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
sub send_to_server($@) |
683
|
|
|
|
|
|
|
{ |
684
|
0
|
|
|
0
|
1
|
|
my $this = shift; |
685
|
0
|
|
|
|
|
|
my $msg = shift; |
686
|
0
|
|
|
|
|
|
$this->connect_to_server(); |
687
|
0
|
0
|
0
|
|
|
|
$this->log("calling server callback ($msg)\n") if $this->{client_to_server_callback} && $this->{verbose}>1; |
688
|
0
|
|
|
|
|
|
$msg = _do_callback( $this->{client_to_server_callback}, $msg ); |
689
|
0
|
|
|
|
|
|
$this->_logmsg(">>>",$msg); |
690
|
0
|
0
|
|
|
|
|
confess "SERVER being null was unexpected" if !$this->{SERVER}; |
691
|
0
|
0
|
|
|
|
|
print({$this->{SERVER}} $msg) || die "Can't send to server: $?"; |
|
0
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
=head2 send_to_client( string(s) ) |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
Sends a message to the client |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
=head3 Parameters |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
=over |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
=item * string(s) - one or more strings to be sent |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
=item * Return: true if successful |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=back |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
=head3 Usage |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
If a callback is set, it will be called before the message is sent. |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
=cut |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
sub send_to_client($@) |
715
|
|
|
|
|
|
|
{ |
716
|
0
|
|
|
0
|
1
|
|
my $this = shift; |
717
|
0
|
|
|
|
|
|
my $msg = shift; |
718
|
0
|
0
|
0
|
|
|
|
$this->echo("calling client callback ($msg)\n") if $this->{server_to_client_callback} && $this->{verbose}>1; |
719
|
0
|
|
|
|
|
|
$msg = _do_callback( $this->{server_to_client_callback}, $msg ); |
720
|
0
|
|
|
|
|
|
$this->_logmsg("<<<",$msg); |
721
|
0
|
|
|
|
|
|
return print({$this->{CLIENT}} $msg); |
|
0
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
=head2 read_from_server( ) |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
Reads a message from the server |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
=head3 Parameters |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
=over |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
=item * --none-- |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
=item * Returns: the message read, or undef if the server disconnected. |
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
=back |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
=head3 Usage |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
Blocks until a message is received. |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
=cut |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
sub read_from_server() |
745
|
|
|
|
|
|
|
{ |
746
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
747
|
0
|
|
|
|
|
|
my $msg; |
748
|
0
|
|
|
|
|
|
sysread($this->{SERVER},$msg,100000); |
749
|
0
|
0
|
|
|
|
|
if(length($msg) == 0) |
750
|
|
|
|
|
|
|
{ |
751
|
0
|
|
|
|
|
|
$this->echo("Server disconnected\n"); |
752
|
0
|
|
|
|
|
|
return undef; |
753
|
|
|
|
|
|
|
} |
754
|
0
|
|
|
|
|
|
return $msg; |
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
=head2 send_and_receive( ) |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
Sends a message to the server and receives a response |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
=head3 Parameters |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
=over |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
=item * the message(s) to be sent |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
=item * Returns: message read, or undef if the server disconnected. |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
=back |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
=head3 Usage |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
Blocks until a message is received. If the server does not always return exactly one message for each message it receives, send_and_receive() will either concatenate messages or block forever. |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
=cut |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
sub send_and_receive($) |
778
|
|
|
|
|
|
|
{ |
779
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
780
|
0
|
|
|
|
|
|
$this->send_to_server(@_); |
781
|
0
|
|
|
|
|
|
return $this->read_from_server(@_); |
782
|
|
|
|
|
|
|
} |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
=head2 connect_to_server( ) |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
Connects to the server |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
=head3 Parameters |
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
=over |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
=item * --none-- |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
=back |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
=head3 Usage |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
This method is automatically called when needed. It only needs to be called directly if you want to be sure that the connection to server succeeds before proceeding. |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
=cut |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
sub connect_to_server() |
803
|
|
|
|
|
|
|
{ |
804
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
805
|
0
|
0
|
|
|
|
|
return if $this->{SERVER}; |
806
|
0
|
0
|
|
|
|
|
socket($this->{SERVER}, PF_INET, SOCK_STREAM, $protocol) or die "Can't create socket: $!"; |
807
|
0
|
0
|
|
|
|
|
confess "remote_ip_address unexpectedly not known" if !$this->{remote_ip_address}; |
808
|
0
|
0
|
|
|
|
|
my $remote_ip_aton = inet_aton( $this->{remote_ip_address} ) or croak "Fatal: Cannot resolve internet address: '$this->{remote_ip_address}'\n"; |
809
|
0
|
0
|
|
|
|
|
my $remote_port_address = sockaddr_in($this->{remote_port_num}, $remote_ip_aton ) or die "Fatal: Can't get port address: $!"; # TODO Is die the way to go here? Not sure it isn't. Not sure it is. |
810
|
0
|
|
|
|
|
|
$this->echo("Connecting to $this->{remote_ip_address}\:$this->{remote_port_num} [verbose=$this->{verbose}]\n"); |
811
|
0
|
0
|
|
|
|
|
connect($this->{SERVER}, $remote_port_address) or confess "Fatal: Can't connect to $this->{remote_ip_address}:$this->{remote_port_num} using $this->{SERVER}. $!"; # TODO Is die the way to go here? Not sure it isn't. Not sure it is. TODO document error handling, one way or the other. |
812
|
0
|
|
|
|
|
|
$this->{SERVER}->autoflush(1); |
813
|
0
|
|
|
|
|
|
binmode($this->{SERVER}); |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
=head2 disconnect_from_server( ) |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
Disconnects from the server |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
=head3 Parameters |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=over |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
=item * --none-- |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
=back |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
=head3 Usage |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
Disconnection is normally triggered by the other party disconnecting, not by us. disconnect_from_server() is most useful with new_client(), and not otherwise supported. |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
=cut |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
sub disconnect_from_server() |
836
|
|
|
|
|
|
|
{ |
837
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
838
|
0
|
|
|
|
|
|
$this->log("initiating disconnect"); |
839
|
0
|
|
|
|
|
|
$this->_destroy(); |
840
|
|
|
|
|
|
|
} |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
sub _pause($){ |
843
|
0
|
|
|
0
|
|
|
select undef,undef,undef,shift; |
844
|
|
|
|
|
|
|
} |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
sub _message_from_client_to_server(){ # TODO Too many too similar sub names, some of which maybe should be public |
847
|
0
|
|
|
0
|
|
|
my $this=shift; |
848
|
|
|
|
|
|
|
# optional sleep to reduce risk of split messages |
849
|
0
|
0
|
|
|
|
|
_pause($this->{defrag_delay}) if $this->{defrag_delay}; |
850
|
|
|
|
|
|
|
# It would be possible to be more agressive by repeatedly waiting until there is a break, but that would probably err too much towards concatenating seperate messages - especially under load. |
851
|
0
|
|
|
|
|
|
my $msg; |
852
|
0
|
|
|
|
|
|
sysread($this->{CLIENT},$msg,10000); |
853
|
|
|
|
|
|
|
# (0 length message means connection closed) |
854
|
0
|
0
|
|
|
|
|
if(length($msg) == 0) { |
855
|
0
|
|
|
|
|
|
$this->echo("Client disconnected\n"); |
856
|
0
|
|
|
|
|
|
$this->_destroy(); |
857
|
0
|
|
|
|
|
|
return; |
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
# Send message to server, if any. Else 'send' to callback function and return result to client. |
860
|
0
|
0
|
|
|
|
|
if($this->{SERVER}){ |
|
|
0
|
|
|
|
|
|
861
|
0
|
|
|
|
|
|
$this->send_to_server($msg); |
862
|
|
|
|
|
|
|
}elsif($this->{server_callback}){ |
863
|
0
|
|
|
|
|
|
$this->send_to_client( $this->{server_callback}($msg) ); |
864
|
|
|
|
|
|
|
}else{ |
865
|
0
|
|
|
|
|
|
confess "$this->{name}: Did not expect to have neither a connection to a SERVER nor a server_callback"; |
866
|
|
|
|
|
|
|
} |
867
|
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
sub _message_from_server_to_client(){ # TODO Too many too similar sub names |
870
|
0
|
|
|
0
|
|
|
my $this=shift; |
871
|
|
|
|
|
|
|
# sleep to avoid splitting messages |
872
|
0
|
0
|
|
|
|
|
_pause($this->{defrag_delay}) if $this->{defrag_delay}; |
873
|
|
|
|
|
|
|
# Read from SERVER and copy to CLIENT |
874
|
0
|
|
|
|
|
|
my $msg = $this->read_from_server(); |
875
|
0
|
0
|
|
|
|
|
if(!defined $msg){ |
876
|
0
|
|
|
|
|
|
$this->echo("Server disconnected\n"); |
877
|
0
|
|
|
|
|
|
$this->_destroy(); |
878
|
0
|
|
|
|
|
|
return; |
879
|
|
|
|
|
|
|
} |
880
|
0
|
|
|
|
|
|
$this->send_to_client($msg); |
881
|
|
|
|
|
|
|
} |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
sub _cull_child() |
884
|
|
|
|
|
|
|
{ |
885
|
0
|
0
|
|
0
|
|
|
my $this=shift or die; |
886
|
0
|
0
|
|
|
|
|
my $child=shift or die; |
887
|
0
|
|
|
|
|
|
for my $i (0 .. @{$this->{children}}){ |
|
0
|
|
|
|
|
|
|
888
|
0
|
0
|
|
|
|
|
if($child==$this->{children}[$i]){ |
889
|
0
|
0
|
|
|
|
|
$this->echo("Child $child->{name} is done, cleaning it up") if $this->{verbose}>1; |
890
|
0
|
|
|
|
|
|
splice @{$this->{children}}, $i,1; |
|
0
|
|
|
|
|
|
|
891
|
0
|
|
|
|
|
|
return; |
892
|
|
|
|
|
|
|
} |
893
|
|
|
|
|
|
|
} |
894
|
0
|
|
|
|
|
|
confess "Child $child->{name} is finished, but I can't find it to clean it up"; |
895
|
|
|
|
|
|
|
} |
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
# _main_loop is called by listeners and by their 'leave-home' children both. When called by listeners, it also includes stay at home children |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
sub _main_loop() |
900
|
|
|
|
|
|
|
{ |
901
|
0
|
|
|
0
|
|
|
my $this=shift; |
902
|
0
|
|
|
|
|
|
my $last_time=time(); |
903
|
|
|
|
|
|
|
# Main Loop |
904
|
0
|
|
|
|
|
|
mainloop: while(1) |
905
|
|
|
|
|
|
|
{ |
906
|
|
|
|
|
|
|
# Build file descriptor list for select call |
907
|
0
|
|
|
|
|
|
my $rin = ""; |
908
|
0
|
0
|
|
|
|
|
if($this->{LISTEN}){ |
909
|
0
|
0
|
|
|
|
|
confess "LISTEN is unexpectedly not a filehandle" if !fileno($this->{LISTEN}); |
910
|
0
|
|
|
|
|
|
vec($rin, fileno($this->{LISTEN}), 1) = 1; |
911
|
|
|
|
|
|
|
} |
912
|
0
|
|
|
|
|
|
foreach my $each ($this, @{$this->{children}}) { |
|
0
|
|
|
|
|
|
|
913
|
0
|
0
|
|
|
|
|
vec($rin, fileno($each->{CLIENT}), 1) = 1 if $each->{CLIENT}; # TODO if no client, child should probably be dead |
914
|
0
|
0
|
|
|
|
|
vec($rin, fileno($each->{SERVER}), 1) = 1 if $each->{SERVER}; |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
# and listen... |
917
|
0
|
|
|
|
|
|
my $rout = $rin; |
918
|
0
|
|
|
|
|
|
my $delay; |
919
|
0
|
0
|
|
|
|
|
if($this->{timer_interval}){ |
920
|
0
|
|
|
|
|
|
$delay=$this->{timer_interval}; |
921
|
|
|
|
|
|
|
}else{ |
922
|
0
|
|
|
|
|
|
$delay=undef; |
923
|
|
|
|
|
|
|
} |
924
|
0
|
|
|
|
|
|
select( $rout, "", "", $delay ); |
925
|
0
|
0
|
0
|
|
|
|
if( $this->{LISTEN} && vec($rout,fileno($this->{LISTEN}),1) ) { |
926
|
0
|
|
|
|
|
|
my $child = $this->_spawn_child(); |
927
|
0
|
0
|
|
|
|
|
push @{$this->{children}}, $child if $child; |
|
0
|
|
|
|
|
|
|
928
|
0
|
|
|
|
|
|
next; |
929
|
|
|
|
|
|
|
} |
930
|
0
|
|
|
|
|
|
foreach my $each($this, @{$this->{children}}) { |
|
0
|
|
|
|
|
|
|
931
|
0
|
0
|
0
|
|
|
|
confess "We have a child with no CLIENT\n" if !$each->{CLIENT} && $each!=$this; |
932
|
0
|
0
|
0
|
|
|
|
if($each->{CLIENT} && vec($rout,fileno($each->{CLIENT}),1) ) { |
933
|
0
|
|
|
|
|
|
$each->_message_from_client_to_server(); # TODO Too many too similar sub names |
934
|
0
|
0
|
|
|
|
|
if(!$each->{CLIENT}){ |
935
|
|
|
|
|
|
|
# client has disconnected |
936
|
0
|
0
|
|
|
|
|
if($each==$this){ |
937
|
|
|
|
|
|
|
# we are the child - OK to exit |
938
|
0
|
|
|
|
|
|
return; #might be better to die or exit at this point instead? |
939
|
|
|
|
|
|
|
}else{ |
940
|
|
|
|
|
|
|
# we are the parent - clean up child and keep going |
941
|
0
|
|
|
|
|
|
$this->_cull_child($each); |
942
|
0
|
|
|
|
|
|
last; # _cull_child impacts the children array - not safe to continue without regenerating rout |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
} |
945
|
|
|
|
|
|
|
} |
946
|
0
|
0
|
0
|
|
|
|
if($each->{SERVER} && vec($rout,fileno($each->{SERVER}),1) ) { |
947
|
0
|
|
|
|
|
|
$each->_message_from_server_to_client(); # TODO Too many too similar sub names |
948
|
0
|
0
|
|
|
|
|
if(!$each->{SERVER}){ |
949
|
|
|
|
|
|
|
# client has disconnected |
950
|
0
|
0
|
|
|
|
|
if($each==$this){ |
951
|
|
|
|
|
|
|
# we are the child - OK to exit |
952
|
0
|
|
|
|
|
|
return; #might be better to die or exit at this point instead? |
953
|
|
|
|
|
|
|
}else{ |
954
|
0
|
|
|
|
|
|
$this->_cull_child($each); |
955
|
0
|
|
|
|
|
|
last; # _cull_child impacts the children array - not safe to continue without regenerating rout |
956
|
|
|
|
|
|
|
} |
957
|
|
|
|
|
|
|
} |
958
|
|
|
|
|
|
|
} |
959
|
|
|
|
|
|
|
} |
960
|
0
|
0
|
|
|
|
|
if($this->{timer_callback}){ |
961
|
0
|
0
|
|
|
|
|
$this->{timer_callback}() or last; |
962
|
|
|
|
|
|
|
} |
963
|
|
|
|
|
|
|
} |
964
|
|
|
|
|
|
|
} |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
=head2 hhmmss( ) |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
The default timestamp function - returns localtime in hh:mm:ss format |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
=head3 Parameters |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
=over |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
=item * --none-- |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
=back |
978
|
|
|
|
|
|
|
|
979
|
|
|
|
|
|
|
=head3 Usage |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
This function is, by default, called when a message is written to the log file. |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
It may be overridden by calling mydate(). |
984
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
=cut |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
sub hhmmss() |
988
|
|
|
|
|
|
|
{ |
989
|
0
|
|
|
0
|
1
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(); |
990
|
0
|
|
|
|
|
|
return sprintf "%02d:%02d:%02d",$hour,$min,$sec; |
991
|
|
|
|
|
|
|
} |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
=head2 mydate( ) |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
Override the standard hh:mm:ss datestamp |
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
=head3 Parameters |
998
|
|
|
|
|
|
|
|
999
|
|
|
|
|
|
|
=over |
1000
|
|
|
|
|
|
|
|
1001
|
|
|
|
|
|
|
=item * datestamp_callback - a reference to a function that returns a datestamp |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
=back |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
=head3 Usage |
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
For example: |
1008
|
|
|
|
|
|
|
|
1009
|
|
|
|
|
|
|
sub ymdhms { |
1010
|
|
|
|
|
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(); |
1011
|
|
|
|
|
|
|
return sprintf "%02d/%02d/%02d %02d:%02d:%02d", |
1012
|
|
|
|
|
|
|
$year+1900,$mon+1,$mday,$hour,$min,$sec; |
1013
|
|
|
|
|
|
|
} |
1014
|
|
|
|
|
|
|
mydate(\&ymdhms); |
1015
|
|
|
|
|
|
|
|
1016
|
|
|
|
|
|
|
=cut |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
sub mydate(;$) |
1019
|
|
|
|
|
|
|
{ |
1020
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
1021
|
0
|
|
0
|
|
|
|
my $mydate=shift||undef; |
1022
|
0
|
0
|
|
|
|
|
if(defined $mydate){ |
1023
|
0
|
|
|
|
|
|
$this->{mydate} = $mydate; |
1024
|
|
|
|
|
|
|
} |
1025
|
0
|
|
|
|
|
|
return $this->{mydate}; |
1026
|
|
|
|
|
|
|
} |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
=head2 listen( ) |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
Listen on local_port and prepare to accept incoming connections |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
=head3 Parameters |
1033
|
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
|
=over |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
=item * --none-- |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
=back |
1039
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
=head3 Usage |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
This method is called by go(). It only needs to be called directly if go() is being bypassed for some reason. |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
=cut |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
sub listen() |
1047
|
|
|
|
|
|
|
{ |
1048
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
1049
|
0
|
0
|
|
|
|
|
return if $this->{LISTEN}; |
1050
|
0
|
0
|
|
|
|
|
$this->echo(sprintf "Server %u listening on port %d (%s)\n",$$,$this->{local_port_num},$this->{parallel}?"parallel":"serial"); |
1051
|
|
|
|
|
|
|
# open tcp/ip socket - see blue camel book pg 349 |
1052
|
0
|
0
|
|
|
|
|
socket($this->{LISTEN}, PF_INET, SOCK_STREAM, $protocol) or die "Fatal: Can't create socket: $!"; |
1053
|
0
|
0
|
|
|
|
|
bind($this->{LISTEN}, sockaddr_in($this->{local_port_num}, INADDR_ANY)) or die "Fatal: Can't bind socket $this->{local_port_num}: $!"; |
1054
|
0
|
0
|
|
|
|
|
listen($this->{LISTEN},1) or die "Fatal: Can't listen to socket: $!"; |
1055
|
0
|
|
|
|
|
|
$this->echo("Waiting on port $this->{local_port_num}\n"); |
1056
|
|
|
|
|
|
|
} |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
sub _accept($) |
1059
|
|
|
|
|
|
|
{ |
1060
|
|
|
|
|
|
|
# Accept a new connection |
1061
|
0
|
|
|
0
|
|
|
my $this=shift; |
1062
|
0
|
|
|
|
|
|
my $LISTEN=shift; |
1063
|
0
|
|
|
|
|
|
my $client_paddr = accept($this->{CLIENT}, $LISTEN); |
1064
|
0
|
|
|
|
|
|
$this->{CLIENT}->autoflush(1); |
1065
|
0
|
|
|
|
|
|
binmode($this->{CLIENT}); |
1066
|
0
|
|
|
|
|
|
my ($client_port, $client_iaddr) = sockaddr_in( $client_paddr ); |
1067
|
0
|
|
|
|
|
|
$this->log("Connection accepted from", inet_ntoa($client_iaddr).":$client_port\n"); |
1068
|
0
|
0
|
|
|
|
|
$this->connect_to_server() if $this->{remote_ip_address}; |
1069
|
|
|
|
|
|
|
} |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
sub _new_child(){ |
1072
|
0
|
|
|
0
|
|
|
my $parent=shift; |
1073
|
0
|
|
|
|
|
|
my $child=_new(); |
1074
|
0
|
|
|
|
|
|
my $all_good=1; |
1075
|
0
|
|
|
|
|
|
foreach my $key (keys %{$parent}){ |
|
0
|
|
|
|
|
|
|
1076
|
0
|
0
|
|
|
|
|
if($key=~m/^(LISTEN|children|connections|name|timer_interval|timer_callback)$/){ |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
# do nothing - these parameters are not inherited |
1078
|
|
|
|
|
|
|
}elsif($key =~ m/^(parallel|log_file|verbose|mydate|.*callback|(local|remote)_(port_num|ip_address))$/){ |
1079
|
0
|
|
|
|
|
|
$child->{$key}=$parent->{$key}; |
1080
|
|
|
|
|
|
|
}elsif($key eq "LOGFILE"){ |
1081
|
|
|
|
|
|
|
# TODO might want to have a different logfile for each child, or at least, an option to do so. |
1082
|
0
|
|
|
|
|
|
$child->{$key}=$parent->{$key}; |
1083
|
|
|
|
|
|
|
}else{ |
1084
|
0
|
|
|
|
|
|
warn "internal error - unexpected attribute: $key = {$parent->$key}\n"; |
1085
|
0
|
|
|
|
|
|
$all_good=0; |
1086
|
|
|
|
|
|
|
} |
1087
|
|
|
|
|
|
|
} |
1088
|
0
|
0
|
|
|
|
|
die "Internal error in _new_child()" unless $all_good; |
1089
|
0
|
|
|
|
|
|
return bless $child; |
1090
|
|
|
|
|
|
|
} |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
sub _spawn_child(){ |
1093
|
0
|
|
|
0
|
|
|
my $this=shift; |
1094
|
0
|
|
|
|
|
|
my $child = $this->_new_child(); |
1095
|
0
|
|
|
|
|
|
$child->_accept($this->{LISTEN}); |
1096
|
0
|
0
|
|
|
|
|
confess "We have a child with no CLIENT\n" if !$child->{CLIENT}; |
1097
|
|
|
|
|
|
|
# hand-off the connection |
1098
|
0
|
|
|
|
|
|
$this->echo("starting connection:",++$this->{connections}); |
1099
|
0
|
0
|
|
|
|
|
if(!$this->{parallel}){ |
1100
|
0
|
|
|
|
|
|
return $child; |
1101
|
|
|
|
|
|
|
} |
1102
|
0
|
|
|
|
|
|
$SIG{CLD} = "IGNORE"; # TODO: shouldn't assume that the caller is happy to have SIGCLD ignored. But nor should we assume the caller is happy to hav SIGCHD overridden. |
1103
|
0
|
|
|
|
|
|
my $pid = fork(); |
1104
|
0
|
0
|
|
|
|
|
if(!defined $pid){ |
|
|
0
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
# Error |
1106
|
0
|
|
|
|
|
|
$this->echo("Cannot fork!: $!\nNew connection will run in the current thread\n"); |
1107
|
0
|
|
|
|
|
|
return $child; |
1108
|
|
|
|
|
|
|
}elsif(!$pid){ |
1109
|
|
|
|
|
|
|
# This is the child process |
1110
|
0
|
0
|
|
|
|
|
$child->echo(sprintf"Running %u",$$) if $child->{verbose}>1; |
1111
|
0
|
0
|
|
|
|
|
confess "We have a child with no CLIENT\n" if !$child->{CLIENT}; |
1112
|
|
|
|
|
|
|
# The active instanct of the parent is in a different process |
1113
|
|
|
|
|
|
|
# Ideally, we would have the parent go out of scope, but all we can do is clean up the bits that matter |
1114
|
0
|
|
|
|
|
|
close $this->{LISTEN}; |
1115
|
0
|
|
|
|
|
|
$child->_main_loop(); |
1116
|
0
|
0
|
|
|
|
|
$child->echo(sprintf"Exiting %u",$$) if $child->{verbose}>1; |
1117
|
0
|
|
|
|
|
|
exit; |
1118
|
|
|
|
|
|
|
}else{ |
1119
|
|
|
|
|
|
|
# This is the parent process. The active child instance is in its own process, we clean up what we can |
1120
|
0
|
|
|
|
|
|
$child->_destroy(); |
1121
|
0
|
|
|
|
|
|
return undef; |
1122
|
|
|
|
|
|
|
} |
1123
|
|
|
|
|
|
|
} |
1124
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
sub go() |
1126
|
|
|
|
|
|
|
{ |
1127
|
0
|
|
|
0
|
1
|
|
my $this=shift; |
1128
|
0
|
|
|
|
|
|
$this->listen(); |
1129
|
0
|
|
|
|
|
|
$this->_main_loop(); |
1130
|
|
|
|
|
|
|
} |
1131
|
|
|
|
|
|
|
|
1132
|
|
|
|
|
|
|
sub _destroy() |
1133
|
|
|
|
|
|
|
{ |
1134
|
0
|
|
|
0
|
|
|
my $this=shift; |
1135
|
0
|
0
|
|
|
|
|
close $this->{CLIENT} if($this->{CLIENT}); |
1136
|
0
|
0
|
|
|
|
|
close $this->{SERVER} if($this->{SERVER}); |
1137
|
0
|
|
|
|
|
|
$this->{SERVER}=$this->{CLIENT}=undef; |
1138
|
|
|
|
|
|
|
} |
1139
|
|
|
|
|
|
|
|
1140
|
|
|
|
|
|
|
=head1 Exports |
1141
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
MitM does not export any functions or variables. It does set SIGCHD to IGNORE, and as advertised, it calls fork() if parallel() is turned on, which by default it is not. |
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
=head1 AUTHOR |
1145
|
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
|
Ben AVELING, C<< >> |
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
=head1 BUGS |
1149
|
|
|
|
|
|
|
|
1150
|
|
|
|
|
|
|
Please report any bugs or feature requests to C, or through |
1151
|
|
|
|
|
|
|
the web interface at L. I will be notified, and then you'll |
1152
|
|
|
|
|
|
|
automatically be notified of progress on your bug as I make changes. |
1153
|
|
|
|
|
|
|
|
1154
|
|
|
|
|
|
|
=head1 SUPPORT |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
1157
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
perldoc NET::MitM |
1159
|
|
|
|
|
|
|
|
1160
|
|
|
|
|
|
|
You can also look for information at: |
1161
|
|
|
|
|
|
|
|
1162
|
|
|
|
|
|
|
=over |
1163
|
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker (report bugs here) |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
L |
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
L |
1171
|
|
|
|
|
|
|
|
1172
|
|
|
|
|
|
|
=item * CPAN Ratings |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
L |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
=item * Search CPAN |
1177
|
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
|
L |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
=back |
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
I'd like to acknowledge W. Richard Steven's and his fantastic introduction to TCPIP: "TCP/IP Illustrated, Volume 1: The Protocols", Addison-Wesley, 1994. (L). |
1185
|
|
|
|
|
|
|
It got me started. Recommend. RIP. |
1186
|
|
|
|
|
|
|
The Blue Camel Book is also pretty useful, and Langworth & chromatic's "Perl Testing, A Developer's Notebook" is also worth a hat tip. |
1187
|
|
|
|
|
|
|
|
1188
|
|
|
|
|
|
|
=head1 ALTERNATIVES |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
If what you want is a pure proxy, especially if you want an ssh proxy or support for firewalls, you might want to evaluate Philippe "BooK" Bruhat's L. |
1191
|
|
|
|
|
|
|
|
1192
|
|
|
|
|
|
|
And if you want a full "portable multitasking and networking framework for any event loop", you may be looking for L. |
1193
|
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
|
=head1 LICENSE AND COPYRIGHT |
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
Copyleft 2013 Ben AVELING. |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
1199
|
|
|
|
|
|
|
under the terms of the the Artistic License (2.0). You may obtain a |
1200
|
|
|
|
|
|
|
copy of the full license at: |
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
L |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
Any use, modification, and distribution of the Standard or Modified |
1205
|
|
|
|
|
|
|
Versions is governed by this Artistic License. By using, modifying or |
1206
|
|
|
|
|
|
|
distributing the Package, you accept this license. Do not use, modify, |
1207
|
|
|
|
|
|
|
or distribute the Package, if you do not accept this license. |
1208
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
If your Modified Version has been derived from a Modified Version made |
1210
|
|
|
|
|
|
|
by someone other than you, you are nevertheless required to ensure that |
1211
|
|
|
|
|
|
|
your Modified Version complies with the requirements of this license. |
1212
|
|
|
|
|
|
|
|
1213
|
|
|
|
|
|
|
This license does not grant you the right to use any trademark, service |
1214
|
|
|
|
|
|
|
mark, tradename, or logo of the Copyright Holder. |
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
This license includes the non-exclusive, worldwide, free-of-charge |
1217
|
|
|
|
|
|
|
patent license to make, have made, have, hold and cherish, |
1218
|
|
|
|
|
|
|
use, offer to use, sell, offer to sell, import and |
1219
|
|
|
|
|
|
|
otherwise transfer the Package with respect to any patent claims |
1220
|
|
|
|
|
|
|
licensable by the Copyright Holder that are necessarily infringed by the |
1221
|
|
|
|
|
|
|
Package. If you institute patent litigation (including a cross-claim or |
1222
|
|
|
|
|
|
|
counterclaim) against any party alleging that the Package constitutes |
1223
|
|
|
|
|
|
|
direct or contributory patent infringement, then this Artistic License |
1224
|
|
|
|
|
|
|
to you shall terminate on the date that such litigation is filed. |
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER |
1227
|
|
|
|
|
|
|
AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. |
1228
|
|
|
|
|
|
|
THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR |
1229
|
|
|
|
|
|
|
PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY |
1230
|
|
|
|
|
|
|
YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR |
1231
|
|
|
|
|
|
|
CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR |
1232
|
|
|
|
|
|
|
CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, |
1233
|
|
|
|
|
|
|
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. SO THERE. |
1234
|
|
|
|
|
|
|
|
1235
|
|
|
|
|
|
|
=cut |
1236
|
|
|
|
|
|
|
|
1237
|
|
|
|
|
|
|
1; # End of NET::MitM |