File Coverage

blib/lib/NET/MitM.pm
Criterion Covered Total %
statement 20 290 6.9
branch 0 162 0.0
condition 0 26 0.0
subroutine 7 44 15.9
pod 24 24 100.0
total 51 546 9.3


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